CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-19 16:28:12 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into dates_calc_lib

Browse Source
This commit is contained in:
Raphaël Monat 2022-08-06 17:26:55 +02:00
commit ffd2e1dec3
223 changed files with 79720 additions and 19870 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.git-blame-ignore-revs
View File

@ -1,6 +1,10 @@
# Reformatting commits to be skipped when running 'git blame'
# Use `git config --global blame.ignoreRevsFile .git-blame-ignore-revs` to use it
# Add new reformatting commits at the top
99b6fc33b508c879f669172005b6c359d7d4f596
7485c7f2ce726f59f1ec66ddfe1d3f7d640201d8
f9fc1a8e8b0b2dcbf5361f95ca778df63ac4e247
f17875f90e07688f683e5ea6e880c57ded640a81

7
.gitattributes vendored
View File

@ -2,7 +2,14 @@
*.mld linguist-documentation
*.md linguist-documentation
*.hints linguist-generated
french_law/js/french_law.js binary linguist-generated
french_law/ocaml/law_source/allocations_familiales.ml binary linguist-generated
french_law/ocaml/law_source/allocations_familiales_api_web.ml binary linguist-generated
french_law/ocaml/law_source/unit_tests/tests_allocations_famiales.ml binary linguist-generated
french_law/python/src/allocations_familiales.py binary linguist-generated
french_law/ocaml/law_source/aides_logement.ml binary linguist-generated
french_law/ocaml/law_source/aides_logement_api_web.ml binary linguist-generated
french_law/python/src/aides_logement.py binary linguist-generated

28
.github/workflows/run-builds.yml vendored
View File

@ -6,34 +6,6 @@ on:
workflow_dispatch:
jobs:
build-ubuntu:
runs-on: ubuntu-latest
steps:
- name: Checkout code
uses: actions/checkout@v2
- name: Set up OCaml
uses: avsm/setup-ocaml@v2
with:
ocaml-compiler: 4.11.x
dune-cache: true
- name: Install external dependencies
run: |
sudo apt-get update && sudo apt-get install python3-dev virtualenv \
python3-setuptools python3-pip python3-pygments man2html rsync \
colordiff npm nodejs libmpc-dev ninja-build pandoc
sudo python3 -m pip install --upgrade pip
sudo python3 -m pip install virtualenv
sudo make pygments
./french_law/python/setup_env.sh
- name: Install OCaml dependencies
run: |
make dependencies-ocaml-with-z3
- name: Make build
run: |
OCAMLRUNPARAM=b opam exec -- make build
build-nix-flake:
runs-on: ubuntu-latest
steps:

48
.github/workflows/run-make-all.yml vendored
View File

@ -11,26 +11,38 @@ jobs:
# The type of runner that the job will run on
runs-on: self-hosted
env:
IMAGE_TAG: ${{ github.head_ref || github.ref_name }}
# Steps represent a sequence of tasks that will be executed as part of the job
steps:
- name: Checkout code
uses: actions/checkout@v2
- name: Re-initialize python dependencies
with:
fetch-depth: 0
- name: Prepare container with all dependencies
run: git archive HEAD | docker build - --target dev-build-context
- name: Run builds, checks and tests
run: git archive HEAD | docker build - --force-rm -t catalalang/catala-build:${IMAGE_TAG}
- name: Cleanup Docker image
if: ${{ github.ref != 'refs/heads/master' }}
run: docker image rm catalalang/catala-build:${IMAGE_TAG}
- name: Build architecture-independent artifacts
if: ${{ github.ref == 'refs/heads/master' }}
run: |
./french_law/python/setup_env.sh
- name: Install dependencies
run: |
opam exec -- make dependencies pygments
- name: Check promoted files
run: |
opam exec -- make check-promoted > promotion.out 2>&1 || touch bad-promote
- name: Make all
run: |
OCAMLRUNPARAM=b opam exec -- make all
- name: Forward result from promotion check
run: |
if [ -e bad-promote ]; then
echo "[ERROR] Some promoted files were not up-to-date";
cat promotion.out;
exit 1
fi
RELEASE_TAG=$(git describe --tags)
mkdir -p artifacts
docker run --rm catalalang/catala-build:${IMAGE_TAG} sh -uexc '
opam --cli=2.1 exec -- dune build --profile=release french_law compiler/catala.bc.js >&2
mv _build/default/compiler/catala.bc.js catala_'"${RELEASE_TAG}"'_node.js >&2
tar c -h catala_'"${RELEASE_TAG}"'_node.js french_law --exclude french_law/js/node_modules --exclude french_law/python/env --exclude '"'"'.*'"'"'
' | tar vx -C artifacts
- name: Build static binaries
if: ${{ github.ref == 'refs/heads/master' }}
run: ./build_release.sh -C artifacts
- name: Publish artifacts
if: ${{ github.ref == 'refs/heads/master' }}
uses: actions/upload-artifact@v3
with:
name: Catala artifacts
path: artifacts/*

1
.gitignore vendored
View File

@ -10,5 +10,6 @@ legifrance_oauth*
*.html
.vscode/
.ninja_*
node_modules/
build.ninja

78
.nix/catala.nix
View File

@ -1,29 +1,29 @@
{ lib
, pkgs
, fetchFromGitHub
, buildDunePackage
, alcotest
, ansiterminal
, sedlex
, menhir
, unionfind
, bindlib
, cmdliner_1_1_0
, re
, zarith
, zarith_stubs_js
, ocamlgraph
, calendar
, visitors
, benchmark
, bindlib
, buildDunePackage
, calendar
, cmdliner_1_1_0
, cppo
, fetchFromGitHub
, js_of_ocaml
, js_of_ocaml-ppx
, camomile
, cppo
, ppx_deriving
, z3
, alcotest
, ppx_yojson_conv
, menhir
, menhirLib ? null #for nixos-unstable compatibility.
, ocamlgraph
, pkgs
, ppx_deriving
, ppx_yojson_conv
, re
, sedlex
, ubase
, unionfind
, visitors
, z3
, zarith
, zarith_stubs_js
}:
buildDunePackage rec {
@ -37,34 +37,30 @@ buildDunePackage rec {
useDune2 = true;
propagatedBuildInputs = [
alcotest
ansiterminal
sedlex
menhir
menhirLib
cmdliner_1_1_0
re
zarith
zarith_stubs_js
ocamlgraph
calendar
visitors
benchmark
bindlib
calendar
camomile
cmdliner_1_1_0
cppo
js_of_ocaml
js_of_ocaml-ppx
ppx_yojson_conv
camomile
cppo
z3
menhir
menhirLib
ocamlgraph
pkgs.z3
ppx_deriving
alcotest
ppx_yojson_conv
re
sedlex
ubase
unionfind
bindlib
visitors
z3
zarith
zarith_stubs_js
] ++ (if isNull menhirLib then [ ] else [ menhirLib ]);
doCheck = true;

2
.ocamlformat
View File

@ -9,3 +9,5 @@ cases-exp-indent=2
indicate-multiline-delimiters=no
parens-tuple=multi-line-only
space-around-lists=false
break-infix-before-func
break-infix= fit-or-vertical

63
Dockerfile
View File

@ -1,13 +1,54 @@
FROM ocaml/opam:ubuntu-lts-ocaml-4.12
# Stage 1: setup an opam switch with all dependencies installed
# (only depends on the opam files)
FROM ocamlpro/ocaml:4.14-2022-07-17 AS dev-build-context
RUN sudo apt-get update && sudo apt-get install -y \
man2html \
colordiff \
latexmk \
python3 \
python3-pip \
libgmp-dev \
npm \
nodejs
# pandoc is not in alpine stable yet, install it manually with an explicit repository
RUN sudo apk add pandoc --repository=http://dl-cdn.alpinelinux.org/alpine/edge/testing/
RUN sudo pip3 install virtualenv
RUN mkdir catala
WORKDIR catala
# Get only the opam files at this stage to allow caching
ADD --chown=ocaml:ocaml *.opam ./
# trigger the selection of catala dev tools in opam
ENV OPAMVAR_cataladevmode=1
ENV OPAMVAR_catalaz3mode=1
# Get a switch with all the dependencies installed
RUN opam --cli=2.1 switch create catala ocaml-system && \
opam --cli=2.1 pin . --no-action && \
opam --cli=2.1 install . --with-test --with-doc --depext-only && \
opam --cli=2.1 install . --with-test --with-doc --deps-only && \
opam clean
# Note: just one `opam switch create .` command should be enough once opam 2.1.3 is released (opam#5047 ; opam#5185)
# Stage 2: get the whole repo, run checks and builds
FROM dev-build-context
# Get the full repo
ADD --chown=ocaml:ocaml . .
# Prepare extra local dependencies
RUN opam exec -- make pygments dependencies-js
RUN opam exec -- ./french_law/python/setup_env.sh
# OCaml backtraces may be useful on failure
ENV OCAMLRUNPARAM=b
# Check promoted files (but delay failure)
RUN opam exec -- make check-promoted > promotion.out 2>&1 || touch bad-promote
# Check the build
RUN opam exec -- make build
# Check tests & all alt targets
RUN OCAMLRUNPARAM=b opam exec -- make all -B
# Forward results of promotion check
RUN if [ -e bad-promote ]; then \
echo "[ERROR] Some promoted files were not up-to-date"; \
cat promotion.out; \
exit 1; \
fi

40
INSTALL.md
View File

@ -11,11 +11,11 @@ Start by installing Docker: https://docs.docker.com/get-docker/
Then build the Docker image:
docker build . -t catala
docker build . --target dev-build-context -t catala
Finally, start a `bash` shell inside a new container created from the newly built image:
Finally, start a shell inside a new container created from the newly built image:
docker run -it -v $PWD:$PWD -w $PWD --name catala catala bash
docker run -it --name catala catala
### With nix
@ -41,18 +41,20 @@ OCaml's distribution and package manager. Follow the [instructions on the `opam`
website](https://opam.ocaml.org/doc/Install.html).
Next, you will need to use the correct version of OCaml. Catala has been tested
with OCaml compiler versions that are at least 4.12.0. To switch to OCaml 4.12.0.,
with OCaml compiler versions that are at least 4.13.0. To switch to OCaml 4.13.0.,
just use:
opam switch 4.12.0
opam switch 4.13.0
If you get a `No switch 4.12.0 is currently installed` error message, follow
the hint and enter `opam switch create 4.12.0`.
If you get a `No switch 4.13.0 is currently installed` error message, follow
the hint and enter `opam switch create 4.13.0`.
## Dependencies
Next, install all the OCaml packages that Catala depend on, as well as some
git submodules, with
You can skip this step if you used the *Docker* option above, it is already taken
care of.
Next, install all the packages that Catala depends on with
make dependencies
@ -61,23 +63,13 @@ This should ensure everything is set up for developing on the Catala compiler!
**Warning**: this command does not include the `z3` dependency required to enable
the proof platform feature of Catala. If you wish to enable support for the
proof platform and the `Proof` command of the Catala compiler, you should
instead execute `make dependencies-with-ocaml` prior to building the compiler.
instead execute `make dependencies-with-z3` prior to building the compiler.
Other features of the Catala repository also require the following executables
to be present
to be present. On debian, arch or apline-based distributions, the above command
should already take care of them.
man2html virtualenv python3 pip rsync colordiff pygmentize nodejs npm
please install them if they're not here, otherwise you will get some errors.
On a Debian distribution, this can be
done with
sudo apt install python3-dev virtualenv python3-setuptools python3-pip python3-pygments man2html rsync colordiff npm nodejs libmpc-dev ninja-build
sudo python3 -m pip install --upgrade pip
On ArchLinux :
sudo pacman -S python-virtualenv man2html rsync colordiff nodejs npm
groff virtualenv python3 pip rsync colordiff pygmentize nodejs npm
## Build
@ -112,7 +104,7 @@ Catala website.
./generate_website_assets.sh <path-to-catala-website>/assets
You will need the `man2html` executable to generate the HTML versions of the man
You will need the `groff` 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.

159
Makefile
View File

@ -3,6 +3,8 @@ help : Makefile
ROOT_DIR:=$(shell dirname $(realpath $(firstword $(MAKEFILE_LIST))))
export DUNE_PROFILE ?= release
# Export all variables to sub-make
export
@ -10,28 +12,30 @@ export
# Dependencies
##########################################
EXECUTABLES = man2html python3 colordiff node pygmentize node npm ninja pandoc
EXECUTABLES = groff python3 colordiff node pygmentize node npm ninja pandoc
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)))
OPAM = opam --cli=2.1
dependencies-ocaml:
opam install . ./doc/catala-dev-dependencies.opam --deps-only --with-doc --with-test --yes
$(OPAM) pin . --no-action
OPAMVAR_cataladevmode=1 $(OPAM) install . --with-doc --with-test --update-invariant --depext-only
OPAMVAR_cataladevmode=1 $(OPAM) install . --with-doc --with-test --update-invariant --deps-only
dependencies-ocaml-with-z3:
opam install . ./doc/catala-dev-dependencies.opam z3 --deps-only --with-doc --with-test --yes
$(OPAM) pin . --no-action
OPAMVAR_cataladevmode=1 OPAMVAR_catalaz3mode=1 $(OPAM) install . --with-doc --with-test --update-invariant --depext-only
OPAMVAR_cataladevmode=1 OPAMVAR_catalaz3mode=1 $(OPAM) install . --with-doc --with-test --update-invariant --deps-only
dependencies-js:
$(MAKE) -C $(FRENCH_LAW_JS_LIB_DIR) dependencies
init-submodules:
git submodule update --init
#> dependencies : Install the Catala OCaml, JS and Git dependencies
dependencies: dependencies-ocaml dependencies-js init-submodules
dependencies: dependencies-ocaml dependencies-js
dependencies-with-z3: dependencies-ocaml-with-z3 dependencies-js init-submodules
dependencies-with-z3: dependencies-ocaml-with-z3 dependencies-js
##########################################
# Catala compiler rules
@ -42,16 +46,18 @@ BUILD_SYSTEM_DIR=build_system
#> build_dev : Builds the Catala compiler, without formatting code
build_dev: parser-messages
dune build $(COMPILER_DIR)/catala.exe $(BUILD_SYSTEM_DIR)/clerk.exe
dune build \
$(COMPILER_DIR)/catala.exe \
$(COMPILER_DIR)/plugins/ \
$(BUILD_SYSTEM_DIR)/clerk.exe
#> build : Builds the Catala compiler
build: parser-messages format
dune build $(COMPILER_DIR)/catala.exe $(BUILD_SYSTEM_DIR)/clerk.exe
build: parser-messages format build_dev
#> js_build : Builds the Web-compatible JS versions of the Catala compiler
js_build:
dune build $(COMPILER_DIR)/catala.bc.js --profile release
dune build $(COMPILER_DIR)/catala_web_interpreter.bc.js --profile release
dune build $(COMPILER_DIR)/catala.bc.js
dune build $(COMPILER_DIR)/catala_web_interpreter.bc.js
#> doc : Generates the HTML OCaml documentation
doc:
@ -61,8 +67,12 @@ doc:
install:
dune build @install
#> plugins : Builds the demonstration plugins
plugins:
#> runtimes : Builds the OCaml and js_of_ocaml runtimes
runtimes:
dune build runtimes/
#> plugins : Builds the compiler backend plugins
plugins: runtimes
dune build compiler/plugins/
@echo "define CATALA_PLUGINS=_build/default/compiler/plugins to test the plugins"
@ -74,11 +84,11 @@ check-promoted:
dune build @update-parser-messages @fmt
compiler/surface/parser.messages: compiler/surface/tokens.mly compiler/surface/parser.mly
dune build @update-parser-messages --auto-promote || true
-dune build @update-parser-messages --auto-promote
parser-messages: compiler/surface/parser.messages
format:
dune build @fmt --auto-promote 2>/dev/null || true
-dune build @fmt --auto-promote 2>/dev/null
##########################################
# Syntax highlighting rules
@ -188,32 +198,44 @@ literate_examples: literate_allocations_familiales literate_code_general_impots
# OCaml
#-----------------------------------------
FRENCH_LAW_OCAML_LIB_DIR=french_law/ocaml
FRENCH_LAW_OCAML_LIB_DIR = french_law/ocaml
$(FRENCH_LAW_OCAML_LIB_DIR)/law_source/allocations_familiales.ml:
CATALA_OPTS="$(CATALA_OPTS) -t" $(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) allocations_familiales.ml
cp -f $(ALLOCATIONS_FAMILIALES_DIR)/allocations_familiales.ml $@
FRENCH_LAW_LIBRARY_OCAML = \
$(FRENCH_LAW_OCAML_LIB_DIR)/law_source/allocations_familiales_api_web.ml \
$(FRENCH_LAW_OCAML_LIB_DIR)/law_source/unit_tests/tests_allocations_familiales.ml \
$(FRENCH_LAW_OCAML_LIB_DIR)/law_source/aides_logement_api_web.ml
$(FRENCH_LAW_OCAML_LIB_DIR)/law_source/unit_tests/tests_allocations_familiales.ml:
CATALA_OPTS="$(CATALA_OPTS) -t" $(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) tests/tests_allocations_familiales.ml
cp -f $(ALLOCATIONS_FAMILIALES_DIR)/tests/tests_allocations_familiales.ml $@
$(addprefix _build/default/,$(FRENCH_LAW_LIBRARY_OCAML)) :
dune build $@
#> generate_french_law_library_ocaml : Generates the French law library OCaml sources from Catala
generate_french_law_library_ocaml:\
$(FRENCH_LAW_OCAML_LIB_DIR)/law_source/allocations_familiales.ml \
$(FRENCH_LAW_OCAML_LIB_DIR)/law_source/unit_tests/tests_allocations_familiales.ml
$(MAKE) format
generate_french_law_library_ocaml:
dune build $(FRENCH_LAW_LIBRARY_OCAML)
#> build_french_law_library_ocaml : Builds the OCaml French law library
build_french_law_library_ocaml: generate_french_law_library_ocaml format
build_french_law_library_ocaml:
dune build $(FRENCH_LAW_OCAML_LIB_DIR)/api.a
run_french_law_library_benchmark_ocaml: generate_french_law_library_ocaml
run_french_law_library_benchmark_ocaml:
dune exec --profile release $(FRENCH_LAW_OCAML_LIB_DIR)/bench.exe
run_french_law_library_ocaml_tests: build_french_law_library_ocaml
run_french_law_library_ocaml_tests:
dune exec $(FRENCH_LAW_OCAML_LIB_DIR)/law_source/unit_tests/run_tests.exe
#-----------------------------------------
# JSON schemas
#-----------------------------------------
JSON_SCHEMAS = \
$(AIDES_LOGEMENT_DIR)/aides_logement_schema.json \
$(ALLOCATIONS_FAMILIALES_DIR)/allocations_familiales_schema.json
#> generate_french_law_json_schemas : Generates the French law library JSON schemas
$(addprefix _build/default/,$(JSON_SCHEMAS)):
dune build $@
generate_french_law_json_schemas:
dune build $(JSON_SCHEMAS)
#-----------------------------------------
# JS
@ -225,10 +247,11 @@ run_french_law_library_benchmark_js: build_french_law_library_js
$(MAKE) -C $(FRENCH_LAW_JS_LIB_DIR) bench
#> build_french_law_library_js : Builds the JS version of the OCaml French law library
build_french_law_library_js: generate_french_law_library_ocaml format
dune build --profile release $(FRENCH_LAW_OCAML_LIB_DIR)/api_web.bc.js
cp -f $(ROOT_DIR)/_build/default/$(FRENCH_LAW_OCAML_LIB_DIR)/api_web.bc.js $(FRENCH_LAW_JS_LIB_DIR)/french_law.js
build_french_law_library_js:
dune build $(FRENCH_LAW_JS_LIB_DIR)/french_law.js
#> build_french_law_library_web_api : Builds the web API of the French law library
build_french_law_library_web_api: build_french_law_library_js generate_french_law_json_schemas
#-----------------------------------------
# Python
@ -236,23 +259,31 @@ build_french_law_library_js: generate_french_law_library_ocaml format
FRENCH_LAW_PYTHON_LIB_DIR=french_law/python
$(FRENCH_LAW_PYTHON_LIB_DIR)/src/allocations_familiales.py:
CATALA_OPTS="$(CATALA_OPTS) -O -t" $(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) allocations_familiales.py
cp -f $(ALLOCATIONS_FAMILIALES_DIR)/allocations_familiales.py $@
FRENCH_LAW_LIBRARY_PYTHON = \
$(FRENCH_LAW_PYTHON_LIB_DIR)/src/allocations_familiales.py \
$(FRENCH_LAW_PYTHON_LIB_DIR)/src/aides_logement.py
PY_VIRTUALENV = $(FRENCH_LAW_PYTHON_LIB_DIR)/env/bin/activate
$(PY_VIRTUALENV):
@$(if $(wildcard $(PY_VIRTUALENV)),,$(error "Python virtualenv not initialised, you need to run $(FRENCH_LAW_PYTHON_LIB_DIR)/setup_env.sh"))
$(FRENCH_LAW_LIBRARY_PYTHON):
dune build $@
#> generate_french_law_library_python : Generates the French law library Python sources from Catala
generate_french_law_library_python:\
$(FRENCH_LAW_PYTHON_LIB_DIR)/src/allocations_familiales.py
. $(FRENCH_LAW_PYTHON_LIB_DIR)/env/bin/activate ;\
$(MAKE) -C $(FRENCH_LAW_PYTHON_LIB_DIR) format
generate_french_law_library_python:
dune build $(FRENCH_LAW_LIBRARY_PYTHON)
#> type_french_law_library_python : Types the French law library Python sources with mypy
type_french_law_library_python: generate_french_law_library_python
. $(FRENCH_LAW_PYTHON_LIB_DIR)/env/bin/activate ;\
type_french_law_library_python: $(PY_VIRTUALENV) \
generate_french_law_library_python
. $(PY_VIRTUALENV) ;\
$(MAKE) -C $(FRENCH_LAW_PYTHON_LIB_DIR) type
run_french_law_library_benchmark_python: type_french_law_library_python
. $(FRENCH_LAW_PYTHON_LIB_DIR)/env/bin/activate ;\
run_french_law_library_benchmark_python: $(PY_VIRTUALENV) \
type_french_law_library_python
. $(PY_VIRTUALENV) ;\
$(MAKE) -C $(FRENCH_LAW_PYTHON_LIB_DIR) bench
##########################################
@ -272,10 +303,10 @@ CLERK=$(CLERK_BIN) --exe $(CATALA_BIN) \
.FORCE:
test_suite: .FORCE
$(CLERK) test tests
OCAMLRUNPARAM= $(CLERK) test tests
test_examples: .FORCE
$(CLERK) test examples
OCAMLRUNPARAM= $(CLERK) test examples
#> tests : Run interpreter tests
tests: test_suite test_examples
@ -299,15 +330,14 @@ tests/%: .FORCE
# Website assets
##########################################
grammar.html: $(COMPILER_DIR)/surface/parser.mly
obelisk html -o $@ $<
WEBSITE_ASSETS = grammar.html catala.html
catala.html: $(COMPILER_DIR)/utils/cli.ml
dune exec $(COMPILER_DIR)/catala.exe -- --help=groff | man2html | sed -e '1,8d' \
| tac | sed "1,20d" | tac > $@
$(addprefix _build/default/,$(WEBSITE_ASSETS)):
dune build $@
#> website-assets : Builds all the assets necessary for the Catala website
website-assets: doc js_build literate_examples grammar.html catala.html build_french_law_library_js
website-assets: js_build literate_examples build_french_law_library_web_api doc
dune build $(WEBSITE_ASSETS)
##########################################
# Misceallenous
@ -315,20 +345,23 @@ website-assets: doc js_build literate_examples grammar.html catala.html build_fr
#> all : Run all make commands
all: \
build js_build doc website-assets\
build js_build doc \
tests \
runtimes \
plugins \
generate_french_law_library_ocaml build_french_law_library_ocaml \
tests_ocaml bench_ocaml \
build_french_law_library_js \
bench_js \
generate_french_law_library_python type_french_law_library_python\
bench_python
generate_french_law_library_python type_french_law_library_python \
bench_python \
website-assets
#> clean : Clean build artifacts
clean:
dune clean
rm -rf artifacts
$(MAKE) -C $(ALLOCATIONS_FAMILIALES_DIR) clean
$(MAKE) -C $(US_TAX_CODE_DIR) clean
$(MAKE) -C $(TUTORIEL_FR_DIR) clean
@ -350,6 +383,12 @@ help_catala:
##########################################
# Special targets
##########################################
.PHONY: inspect clean all literate_examples english allocations_familiales pygments \
install build_dev build doc format dependencies dependencies-ocaml \
catala.html help parser-messages plugins
.PHONY: inspect clean all literate_examples english allocations_familiales \
pygments install build_dev build doc format dependencies \
dependencies-ocaml catala.html help parser-messages plugins \
generate_french_law_json_schemas generate_french_law_library_python \
generate_french_law_library_ocaml \
run_french_law_library_benchmark_python \
run_french_law_library_benchmark_js run_french_law_library_ocaml_tests \
build_french_law_library_js build_french_law_library_web_api \
build_french_law_library_ocaml

46
build_release.sh Executable file
View File

@ -0,0 +1,46 @@
#! /usr/bin/env sh
set -ue
RELEASE_TAG=${RELEASE_TAG:-$(git describe --tags 2>/dev/null || echo dev)}
BIN_TAG=${BIN_TAG:-$(uname -s)_$(uname -m)}
CUSTOM_LINKING_CATALA_Z3="\
(-cclib -static
-cclib -no-pie
-noautolink
-cclib -L/home/ocaml/.opam/z3/lib/stublibs
-cclib -lz3ml-static
-cclib -lz3
-cclib -lstdc++
-cclib -lthreadsnat
-cclib -lzarith
-cclib -lgmp
-cclib -lcamlstr
-cclib -lANSITerminal_stubs
-cclib -lunix)"
CUSTOM_LINKING_CATALA_NOZ3="(-cclib -static -cclib -no-pie)"
CUSTOM_LINKING_CLERK="(-cclib -static -cclib -no-pie)"
git archive HEAD --prefix catala/ | \
docker run --rm -i registry.gitlab.inria.fr/lgesbert/catala-ci-images:ocaml.4.14-z3static.4.10.1 \
sh -uexc \
'{ tar x &&
cd catala &&
echo "'"${CUSTOM_LINKING_CATALA_Z3}"'" >compiler/custom_linking.sexp &&
echo "'"${CUSTOM_LINKING_CLERK}"'" >build_system/custom_linking.sexp &&
opam --cli=2.1 install ./ninja_utils.opam ./clerk.opam ./catala.opam --destdir ../release.out/ &&
mv ../release.out/bin/catala ../release.out/bin/catala-z3 &&
opam --cli=2.1 remove z3 catala &&
echo "'"${CUSTOM_LINKING_CATALA_NOZ3}"'" >compiler/custom_linking.sexp &&
opam --cli=2.1 install ./catala.opam --destdir ../release.out/ &&
rm -f ../release.out/bin/catala_web_interpreter &&
for f in ../release.out/bin/*; do
strip ${f};
mv ${f} ${f}_'"${RELEASE_TAG}"'_'"${BIN_TAG}"';
done;
} >&2 && tar c -hC ../release.out/bin .' |
tar vx "$@"

34
build_system/clerk_driver.ml
View File

@ -24,7 +24,8 @@ module Nj = Ninja_utils
let files_or_folders =
Arg.(
non_empty & pos_right 0 file []
non_empty
& pos_right 0 file []
& info [] ~docv:"FILE(S)" ~doc:"File(s) or folder(s) to process")
let command =
@ -38,7 +39,8 @@ let debug =
let reset_test_outputs =
Arg.(
value & flag
value
& flag
& info ["r"; "reset"]
~doc:
"Used with the `test` command, resets the test output to whatever is \
@ -88,8 +90,16 @@ let catala_opts =
let clerk_t f =
Term.(
const f $ files_or_folders $ command $ catalac $ catala_opts $ makeflags
$ debug $ scope $ reset_test_outputs $ ninja_output)
const f
$ files_or_folders
$ command
$ catalac
$ catala_opts
$ makeflags
$ debug
$ scope
$ reset_test_outputs
$ ninja_output)
let version = "0.5.0"
@ -336,7 +346,8 @@ let collect_all_ninja_build
let expected_output_file =
expected_output.output_dir
^ Filename.basename expected_output.tested_filename
^ "." ^ expected_output.id
^ "."
^ expected_output.id
in
let vars =
[
@ -392,7 +403,8 @@ let add_root_test_build
(all_file_names : string list)
(all_test_builds : string) : ninja =
let file_names_str =
List.hd all_file_names ^ ""
List.hd all_file_names
^ ""
^ List.fold_left
(fun acc name -> acc ^ "; " ^ name)
"" (List.tl all_file_names)
@ -440,9 +452,11 @@ let get_catala_files_in_folder (dir : string) : string list =
false
in
if f_is_dir then
readdir_sort f |> Array.to_list
readdir_sort f
|> Array.to_list
|> List.map (Filename.concat f)
|> List.append fs |> loop result
|> List.append fs
|> loop result
else loop (f :: result) fs
| [] -> result
in
@ -647,7 +661,9 @@ let driver
Nj.format fmt
(add_root_test_build ninja ctx.all_file_names
ctx.all_test_builds));
let ninja_cmd = "ninja " ^ ninja_flags ^ " test -f " ^ ninja_output in
let ninja_cmd =
"ninja -f " ^ ninja_output ^ " " ^ ninja_flags ^ " test"
in
Cli.debug_print "executing '%s'..." ninja_cmd;
Sys.command ninja_cmd
with Sys_error e ->

19
build_system/dune
View File

@ -7,12 +7,29 @@
(library
(name clerk_driver)
(public_name clerk.driver)
(libraries catala.runtime catala.utils ninja_utils cmdliner re ANSITerminal)
(libraries
catala.runtime_ocaml
catala.utils
ninja_utils
cmdliner
re
ANSITerminal)
(modules clerk_driver))
(rule
(target custom_linking.sexp)
(mode fallback)
(action
(with-stdout-to
%{target}
(echo "()"))))
(executable
(name clerk)
(public_name clerk)
(flags
(:standard
(:include custom_linking.sexp)))
(libraries clerk.driver)
(modules clerk)
(package clerk))

44
catala.opam
View File

@ -18,28 +18,34 @@ license: "Apache-2.0"
homepage: "https://github.com/CatalaLang/catala"
bug-reports: "https://github.com/CatalaLang/catala/issues"
depends: [
"dune" {>= "2.8"}
"ocaml" {>= "4.11.0"}
"ANSITerminal" {>= "0.8.2"}
"sedlex" {>= "2.4"}
"menhir" {>= "20200211"}
"menhirLib" {>= "20200211"}
"unionFind" {>= "20200320"}
"benchmark" {>= "1.6"}
"bindlib" {>= "5.0.1"}
"cmdliner" {>= "1.1.0"}
"re" {>= "1.9.0"}
"zarith" {>= "1.12"}
"zarith_stubs_js" {>= "v0.14.1"}
"ocamlgraph" {>= "1.8.8"}
"visitors" {>= "20200210"}
"benchmark" {>= "1.6"}
"js_of_ocaml-ppx" {>= "3.8.0"}
"ppx_yojson_conv" {>= "0.14.0"}
"camomile" {>= "1.0.2"}
"cppo" {>= "1"}
"dates_calc" {>= "0.0.2"}
"dune" {>= "2.8"}
"js_of_ocaml-ppx" {>= "3.8.0"}
"menhir" {>= "20200211"}
"menhirLib" {>= "20200211"}
"ocaml" {>= "4.13.0"}
"ocamlfind" {!= "1.9.5"}
"ocamlgraph" {>= "1.8.8"}
"ppx_yojson_conv" {>= "0.14.0"}
"re" {>= "1.9.0"}
"sedlex" {>= "2.4"}
"ubase" {>= "0.05"}
"unionFind" {>= "20200320"}
"visitors" {>= "20200210"}
"zarith" {>= "1.12"}
"zarith_stubs_js" {>= "v0.14.1"}
"alcotest" {with-test & >= "1.5.0"}
"odoc" {with-doc}
"ocamlformat" {cataladevmode & = "0.21.0"}
"obelisk" {cataladevmode}
"conf-npm" {cataladevmode}
"conf-python-3-dev" {cataladevmode}
"z3" {catalaz3mode}
]
depopts: ["z3"]
conflicts: [
@ -60,3 +66,11 @@ build: [
]
]
dev-repo: "git+https://github.com/CatalaLang/catala.git"
depexts: [
["groff" "colordiff" "latexmk" "python3-pip" "pandoc"]
{cataladevmode & os-family = "debian"}
["groff" "colordiff" "texlive" "py3-pip" "py3-pygments"]
{cataladevmode & os-distribution = "alpine"}
["groff" "colordiff" "latex-mk" "python-pygments" "pandoc"]
{cataladevmode & os-family = "arch"}
]

5
clerk.opam
View File

@ -35,4 +35,7 @@ build: [
]
]
dev-repo: "git+https://github.com/CatalaLang/catala.git"
depexts: ["ninja-build"] {os-family = "debian"}
depexts: [
["ninja-build"] {os-family = "debian"}
["samurai"] {os-distribution = "alpine"}
]

2
compiler/catala_web_interpreter.ml
View File

@ -13,7 +13,7 @@ let _ =
(Contents (Js.to_string contents))
{
Utils.Cli.debug = false;
unstyled = false;
color = Never;
wrap_weaved_output = false;
avoid_exceptions = false;
backend = "Interpret";

732
compiler/dcalc/ast.ml
View File

@ -18,6 +18,7 @@
[@@@ocaml.warning "-7-34"]
open Utils
module Runtime = Runtime_ocaml.Runtime
module ScopeName : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
@ -39,15 +40,15 @@ module EnumConstructor : Uid.Id with type info = Uid.MarkedString.info =
module EnumMap : Map.S with type key = EnumName.t = Map.Make (EnumName)
type typ_lit = TBool | TUnit | TInt | TRat | TMoney | TDate | TDuration
type struct_name = StructName.t
type enum_name = EnumName.t
type typ =
type marked_typ = typ Marked.pos
and typ =
| TLit of typ_lit
| TTuple of typ Pos.marked list * struct_name option
| TEnum of typ Pos.marked list * enum_name
| TArrow of typ Pos.marked * typ Pos.marked
| TArray of typ Pos.marked
| TTuple of marked_typ list * StructName.t option
| TEnum of marked_typ list * EnumName.t
| TArrow of marked_typ * marked_typ
| TArray of marked_typ
| TAny
type date = Runtime.date
@ -95,36 +96,104 @@ type unop =
| Log of log_entry * Utils.Uid.MarkedString.info list
| Length
| IntToRat
| MoneyToRat
| RatToMoney
| GetDay
| GetMonth
| GetYear
| FirstDayOfMonth
| LastDayOfMonth
| RoundMoney
| RoundDecimal
type operator = Ternop of ternop | Binop of binop | Unop of unop
type expr =
| EVar of expr Bindlib.var Pos.marked
| ETuple of expr Pos.marked list * struct_name option
(** Some structures used for type inference *)
module Infer = struct
module Any =
Utils.Uid.Make
(struct
type info = unit
let format_info fmt () = Format.fprintf fmt "any"
end)
()
type unionfind_typ = typ Marked.pos UnionFind.elem
(** 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. *)
and typ =
| TLit of typ_lit
| TArrow of unionfind_typ * unionfind_typ
| TTuple of unionfind_typ list * StructName.t option
| TEnum of unionfind_typ list * EnumName.t
| TArray of unionfind_typ
| TAny of Any.t
let rec typ_to_ast (ty : unionfind_typ) : marked_typ =
let ty, pos = UnionFind.get (UnionFind.find ty) in
match ty with
| TLit l -> TLit l, pos
| TTuple (ts, s) -> TTuple (List.map typ_to_ast ts, s), pos
| TEnum (ts, e) -> TEnum (List.map typ_to_ast ts, e), pos
| TArrow (t1, t2) -> TArrow (typ_to_ast t1, typ_to_ast t2), pos
| TAny _ -> TAny, pos
| TArray t1 -> TArray (typ_to_ast t1), pos
let rec ast_to_typ (ty : marked_typ) : unionfind_typ =
let ty' =
match Marked.unmark ty with
| TLit l -> TLit l
| TArrow (t1, t2) -> TArrow (ast_to_typ t1, ast_to_typ t2)
| TTuple (ts, s) -> TTuple (List.map (fun t -> ast_to_typ t) ts, s)
| TEnum (ts, e) -> TEnum (List.map (fun t -> ast_to_typ t) ts, e)
| TArray t -> TArray (ast_to_typ t)
| TAny -> TAny (Any.fresh ())
in
UnionFind.make (Marked.same_mark_as ty' ty)
end
type untyped = { pos : Pos.t } [@@ocaml.unboxed]
type typed = { pos : Pos.t; ty : marked_typ }
type inferring = { pos : Pos.t; uf : Infer.unionfind_typ }
(** The generic type of AST markings. Using a GADT allows functions to be
polymorphic in the marking, but still do transformations on types when
appropriate *)
type _ mark =
| Untyped : untyped -> untyped mark
| Typed : typed -> typed mark
| Inferring : inferring -> inferring mark
type ('a, 'm) marked = ('a, 'm mark) Marked.t
type 'm marked_expr = ('m expr, 'm) marked
and 'm expr =
| EVar of 'm expr Bindlib.var
| ETuple of 'm marked_expr list * StructName.t option
| ETupleAccess of
expr Pos.marked * int * struct_name option * typ Pos.marked list
| EInj of expr Pos.marked * int * enum_name * typ Pos.marked list
| EMatch of expr Pos.marked * expr Pos.marked list * enum_name
| EArray of expr Pos.marked list
'm marked_expr * int * StructName.t option * typ Marked.pos list
| EInj of 'm marked_expr * int * EnumName.t * typ Marked.pos list
| EMatch of 'm marked_expr * 'm marked_expr list * EnumName.t
| EArray of 'm marked_expr list
| ELit of lit
| EAbs of
(expr, expr Pos.marked) Bindlib.mbinder Pos.marked * typ Pos.marked list
| EApp of expr Pos.marked * expr Pos.marked list
| EAssert of expr Pos.marked
(('m expr, 'm marked_expr) Bindlib.mbinder[@opaque]) * typ Marked.pos list
| EApp of 'm marked_expr * 'm marked_expr list
| EAssert of 'm marked_expr
| EOp of operator
| EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
| ErrorOnEmpty of expr Pos.marked
| EDefault of 'm marked_expr list * 'm marked_expr * 'm marked_expr
| EIfThenElse of 'm marked_expr * 'm marked_expr * 'm marked_expr
| ErrorOnEmpty of 'm marked_expr
type struct_ctx = (StructFieldName.t * typ Pos.marked) list StructMap.t
type enum_ctx = (EnumConstructor.t * typ Pos.marked) list EnumMap.t
type typed_expr = typed marked_expr
type struct_ctx = (StructFieldName.t * typ Marked.pos) list StructMap.t
type enum_ctx = (EnumConstructor.t * typ Marked.pos) list EnumMap.t
type decl_ctx = { ctx_enums : enum_ctx; ctx_structs : struct_ctx }
type binder = (expr, expr Pos.marked) Bindlib.binder
type 'm binder = ('m expr, 'm marked_expr) Bindlib.binder
type scope_let_kind =
| DestructuringInputStruct
@ -134,173 +203,158 @@ type scope_let_kind =
| DestructuringSubScopeResults
| Assertion
type 'expr scope_let = {
type ('expr, 'm) scope_let = {
scope_let_kind : scope_let_kind;
scope_let_typ : typ Utils.Pos.marked;
scope_let_expr : 'expr Utils.Pos.marked;
scope_let_next : ('expr, 'expr scope_body_expr) Bindlib.binder;
scope_let_pos : Utils.Pos.t;
scope_let_typ : typ Marked.pos;
scope_let_expr : ('expr, 'm) marked;
scope_let_next : ('expr, ('expr, 'm) scope_body_expr) Bindlib.binder;
scope_let_pos : Pos.t;
}
and 'expr scope_body_expr =
| Result of 'expr Utils.Pos.marked
| ScopeLet of 'expr scope_let
and ('expr, 'm) scope_body_expr =
| Result of ('expr, 'm) marked
| ScopeLet of ('expr, 'm) scope_let
type 'expr scope_body = {
type ('expr, 'm) scope_body = {
scope_body_input_struct : StructName.t;
scope_body_output_struct : StructName.t;
scope_body_expr : ('expr, 'expr scope_body_expr) Bindlib.binder;
scope_body_expr : ('expr, ('expr, 'm) scope_body_expr) Bindlib.binder;
}
type 'expr scope_def = {
type ('expr, 'm) scope_def = {
scope_name : ScopeName.t;
scope_body : 'expr scope_body;
scope_next : ('expr, 'expr scopes) Bindlib.binder;
scope_body : ('expr, 'm) scope_body;
scope_next : ('expr, ('expr, 'm) scopes) Bindlib.binder;
}
and 'expr scopes = Nil | ScopeDef of 'expr scope_def
and ('expr, 'm) scopes = Nil | ScopeDef of ('expr, 'm) scope_def
type program = { decl_ctx : decl_ctx; scopes : expr scopes }
type ('expr, 'm) program_generic = {
decl_ctx : decl_ctx;
scopes : ('expr, 'm) scopes;
}
let evar (v : expr Bindlib.var) (pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun v' -> v', pos) (Bindlib.box_var v)
type 'm program = ('m expr, 'm) program_generic
let etuple
(args : expr Pos.marked Bindlib.box list)
(s : StructName.t option)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun args -> ETuple (args, s), pos) (Bindlib.box_list args)
let no_mark (type m) : m mark -> m mark = function
| Untyped _ -> Untyped { pos = Pos.no_pos }
| Typed _ -> Typed { pos = Pos.no_pos; ty = Marked.mark Pos.no_pos TAny }
| Inferring _ ->
Inferring
{
pos = Pos.no_pos;
uf = UnionFind.make Infer.(TAny (Any.fresh ()), Pos.no_pos);
}
let etupleaccess
(e1 : expr Pos.marked Bindlib.box)
(i : int)
(s : StructName.t option)
(typs : typ Pos.marked list)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun e1 -> ETupleAccess (e1, i, s, typs), pos) e1
let mark_pos (type m) (m : m mark) : Pos.t =
match m with
| Untyped { pos } | Typed { pos; _ } | Inferring { pos; _ } -> pos
let einj
(e1 : expr Pos.marked Bindlib.box)
(i : int)
(e_name : EnumName.t)
(typs : typ Pos.marked list)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun e1 -> EInj (e1, i, e_name, typs), pos) e1
let pos (type m) (x : ('a, m) marked) : Pos.t = mark_pos (Marked.get_mark x)
let ty (_, m) : marked_typ = match m with Typed { ty; _ } -> ty
let ematch
(arg : expr Pos.marked Bindlib.box)
(arms : expr Pos.marked Bindlib.box list)
(e_name : EnumName.t)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
let with_ty (type m) (ty : marked_typ) (x : ('a, m) marked) : ('a, typed) marked
=
Marked.mark
(match Marked.get_mark x with
| Untyped { pos } | Inferring { pos; _ } -> Typed { pos; ty }
| Typed m -> Typed { m with ty })
(Marked.unmark x)
let evar v mark = Bindlib.box_apply (Marked.mark mark) (Bindlib.box_var v)
let etuple args s mark =
Bindlib.box_apply (fun args -> ETuple (args, s), mark) (Bindlib.box_list args)
let etupleaccess e1 i s typs mark =
Bindlib.box_apply (fun e1 -> ETupleAccess (e1, i, s, typs), mark) e1
let einj e1 i e_name typs mark =
Bindlib.box_apply (fun e1 -> EInj (e1, i, e_name, typs), mark) e1
let ematch arg arms e_name mark =
Bindlib.box_apply2
(fun arg arms -> EMatch (arg, arms, e_name), pos)
(fun arg arms -> EMatch (arg, arms, e_name), mark)
arg (Bindlib.box_list arms)
let earray (args : expr Pos.marked Bindlib.box list) (pos : Pos.t) :
expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun args -> EArray args, pos) (Bindlib.box_list args)
let earray args mark =
Bindlib.box_apply (fun args -> EArray args, mark) (Bindlib.box_list args)
let elit (l : lit) (pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box (ELit l, pos)
let elit l mark = Bindlib.box (ELit l, mark)
let eabs
(binder : (expr, expr Pos.marked) Bindlib.mbinder Bindlib.box)
(pos_binder : Pos.t)
(typs : typ Pos.marked list)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply
(fun binder -> EAbs ((binder, pos_binder), typs), pos)
binder
let eabs binder typs mark =
Bindlib.box_apply (fun binder -> EAbs (binder, typs), mark) binder
let eapp
(e1 : expr Pos.marked Bindlib.box)
(args : expr Pos.marked Bindlib.box list)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
let eapp e1 args mark =
Bindlib.box_apply2
(fun e1 args -> EApp (e1, args), pos)
(fun e1 args -> EApp (e1, args), mark)
e1 (Bindlib.box_list args)
let eassert (e1 : expr Pos.marked Bindlib.box) (pos : Pos.t) :
expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun e1 -> EAssert e1, pos) e1
let eassert e1 mark = Bindlib.box_apply (fun e1 -> EAssert e1, mark) e1
let eop op mark = Bindlib.box (EOp op, mark)
let eop (op : operator) (pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box (EOp op, pos)
let edefault
(excepts : expr Pos.marked Bindlib.box list)
(just : expr Pos.marked Bindlib.box)
(cons : expr Pos.marked Bindlib.box)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
let edefault excepts just cons mark =
Bindlib.box_apply3
(fun excepts just cons -> EDefault (excepts, just, cons), pos)
(fun excepts just cons -> EDefault (excepts, just, cons), mark)
(Bindlib.box_list excepts) just cons
let eifthenelse
(e1 : expr Pos.marked Bindlib.box)
(e2 : expr Pos.marked Bindlib.box)
(e3 : expr Pos.marked Bindlib.box)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply3 (fun e1 e2 e3 -> EIfThenElse (e1, e2, e3), pos) e1 e2 e3
let eifthenelse e1 e2 e3 mark =
Bindlib.box_apply3 (fun e1 e2 e3 -> EIfThenElse (e1, e2, e3), mark) e1 e2 e3
let eerroronempty (e1 : expr Pos.marked Bindlib.box) (pos : Pos.t) :
expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun e1 -> ErrorOnEmpty e1, pos) e1
let eerroronempty e1 mark =
Bindlib.box_apply (fun e1 -> ErrorOnEmpty e1, mark) e1
let map_expr
(ctx : 'a)
~(f : 'a -> expr Pos.marked -> expr Pos.marked Bindlib.box)
(e : expr Pos.marked) : expr Pos.marked Bindlib.box =
match Pos.unmark e with
| EVar (v, _pos) -> evar v (Pos.get_position e)
| EApp (e1, args) ->
eapp (f ctx e1) (List.map (f ctx) args) (Pos.get_position e)
| EAbs ((binder, binder_pos), typs) ->
eabs
(Bindlib.box_mbinder (f ctx) binder)
binder_pos typs (Pos.get_position e)
| ETuple (args, s) -> etuple (List.map (f ctx) args) s (Pos.get_position e)
let translate_var v = Bindlib.copy_var v (fun x -> EVar x) (Bindlib.name_of v)
let map_expr ctx ~f e =
let m = Marked.get_mark e in
match Marked.unmark e with
| EVar v -> evar (translate_var v) m
| EApp (e1, args) -> eapp (f ctx e1) (List.map (f ctx) args) m
| EAbs (binder, typs) ->
let vars, body = Bindlib.unmbind binder in
eabs (Bindlib.bind_mvar (Array.map translate_var vars) (f ctx body)) typs m
| ETuple (args, s) -> etuple (List.map (f ctx) args) s m
| ETupleAccess (e1, n, s_name, typs) ->
etupleaccess ((f ctx) e1) n s_name typs (Pos.get_position e)
| EInj (e1, i, e_name, typs) ->
einj ((f ctx) e1) i e_name typs (Pos.get_position e)
etupleaccess ((f ctx) e1) n s_name typs m
| EInj (e1, i, e_name, typs) -> einj ((f ctx) e1) i e_name typs m
| EMatch (arg, arms, e_name) ->
ematch ((f ctx) arg) (List.map (f ctx) arms) e_name (Pos.get_position e)
| EArray args -> earray (List.map (f ctx) args) (Pos.get_position e)
| ELit l -> elit l (Pos.get_position e)
| EAssert e1 -> eassert ((f ctx) e1) (Pos.get_position e)
| EOp op -> Bindlib.box (EOp op, Pos.get_position e)
ematch ((f ctx) arg) (List.map (f ctx) arms) e_name m
| EArray args -> earray (List.map (f ctx) args) m
| ELit l -> elit l m
| EAssert e1 -> eassert ((f ctx) e1) m
| EOp op -> Bindlib.box (EOp op, m)
| EDefault (excepts, just, cons) ->
edefault
(List.map (f ctx) excepts)
((f ctx) just)
((f ctx) cons)
(Pos.get_position e)
edefault (List.map (f ctx) excepts) ((f ctx) just) ((f ctx) cons) m
| EIfThenElse (e1, e2, e3) ->
eifthenelse ((f ctx) e1) ((f ctx) e2) ((f ctx) e3) (Pos.get_position e)
| ErrorOnEmpty e1 -> eerroronempty ((f ctx) e1) (Pos.get_position e)
eifthenelse ((f ctx) e1) ((f ctx) e2) ((f ctx) e3) m
| ErrorOnEmpty e1 -> eerroronempty ((f ctx) e1) m
let rec map_expr_top_down ~f e =
map_expr () ~f:(fun () -> map_expr_top_down ~f) (f e)
let map_expr_marks ~f e =
map_expr_top_down ~f:(fun e -> Marked.(mark (f (get_mark e)) (unmark e))) e
let untype_expr e = map_expr_marks ~f:(fun m -> Untyped { pos = mark_pos m }) e
type ('expr, 'm) box_expr_sig =
('expr, 'm) marked -> ('expr, 'm) marked Bindlib.box
(** See [Bindlib.box_term] documentation for why we are doing that. *)
let box_expr (e : expr Pos.marked) : expr Pos.marked Bindlib.box =
let box_expr : ('m expr, 'm) box_expr_sig =
fun e ->
let rec id_t () e = map_expr () ~f:id_t e in
id_t () e
type 'expr box_expr_sig = 'expr Pos.marked -> 'expr Pos.marked Bindlib.box
let rec fold_left_scope_lets
~(f : 'a -> 'expr scope_let -> 'expr Bindlib.var -> 'a)
~(init : 'a)
(scope_body_expr : 'expr scope_body_expr) : 'a =
let rec fold_left_scope_lets ~f ~init scope_body_expr =
match scope_body_expr with
| Result _ -> init
| ScopeLet scope_let ->
let var, next = Bindlib.unbind scope_let.scope_let_next in
fold_left_scope_lets ~f ~init:(f init scope_let var) next
let rec fold_right_scope_lets
~(f : 'expr scope_let -> 'expr Bindlib.var -> 'a -> 'a)
~(init : 'expr Pos.marked -> 'a)
(scope_body_expr : 'expr scope_body_expr) : 'a =
let rec fold_right_scope_lets ~f ~init scope_body_expr =
match scope_body_expr with
| Result result -> init result
| ScopeLet scope_let ->
@ -308,39 +362,25 @@ let rec fold_right_scope_lets
let next_result = fold_right_scope_lets ~f ~init next in
f scope_let var next_result
let map_exprs_in_scope_lets
~(f : 'expr Pos.marked -> 'expr Pos.marked Bindlib.box)
(scope_body_expr : 'expr scope_body_expr) :
'expr scope_body_expr Bindlib.box =
let map_exprs_in_scope_lets ~f ~varf scope_body_expr =
fold_right_scope_lets
~f:(fun scope_let var_next (acc : 'expr scope_body_expr Bindlib.box) ->
let new_scope_let =
Bindlib.box_apply
(fun new_expr -> { scope_let with scope_let_expr = new_expr })
(f scope_let.scope_let_expr)
in
let new_next = Bindlib.bind_var var_next acc in
~f:(fun scope_let var_next acc ->
Bindlib.box_apply2
(fun new_next new_scope_let ->
ScopeLet { new_scope_let with scope_let_next = new_next })
new_next new_scope_let)
(fun scope_let_next scope_let_expr ->
ScopeLet { scope_let with scope_let_next; scope_let_expr })
(Bindlib.bind_var (varf var_next) acc)
(f scope_let.scope_let_expr))
~init:(fun res -> Bindlib.box_apply (fun res -> Result res) (f res))
scope_body_expr
let rec fold_left_scope_defs
~(f : 'a -> 'expr scope_def -> 'expr Bindlib.var -> 'a)
~(init : 'a)
(scopes : 'expr scopes) : 'a =
let rec fold_left_scope_defs ~f ~init scopes =
match scopes with
| Nil -> init
| ScopeDef scope_def ->
let var, next = Bindlib.unbind scope_def.scope_next in
fold_left_scope_defs ~f ~init:(f init scope_def var) next
let rec fold_right_scope_defs
~(f : 'expr scope_def -> 'expr Bindlib.var -> 'a -> 'a)
~(init : 'a)
(scopes : 'expr scopes) : 'a =
let rec fold_right_scope_defs ~f ~init scopes =
match scopes with
| Nil -> init
| ScopeDef scope_def ->
@ -348,9 +388,7 @@ let rec fold_right_scope_defs
let result_next = fold_right_scope_defs ~f ~init next in
f scope_def var_next result_next
let map_scope_defs
~(f : 'expr scope_def -> 'expr scope_def Bindlib.box)
(scopes : 'expr scopes) : 'expr scopes Bindlib.box =
let map_scope_defs ~f scopes =
fold_right_scope_defs
~f:(fun scope_def var_next acc ->
let new_scope_def = f scope_def in
@ -361,48 +399,62 @@ let map_scope_defs
new_scope_def new_next)
~init:(Bindlib.box Nil) scopes
let map_exprs_in_scopes
~(f : 'expr Pos.marked -> 'expr Pos.marked Bindlib.box)
(scopes : 'expr scopes) : 'expr scopes Bindlib.box =
map_scope_defs
~f:(fun scope_def ->
let map_exprs_in_scopes ~f ~varf scopes =
fold_right_scope_defs
~f:(fun scope_def var_next acc ->
let scope_input_var, scope_lets =
Bindlib.unbind scope_def.scope_body.scope_body_expr
in
let new_scope_body_expr = map_exprs_in_scope_lets ~f scope_lets in
let new_scope_body_expr = map_exprs_in_scope_lets ~f ~varf scope_lets in
let new_scope_body_expr =
Bindlib.bind_var scope_input_var new_scope_body_expr
Bindlib.bind_var (varf scope_input_var) new_scope_body_expr
in
Bindlib.box_apply
(fun new_scope_body_expr ->
{
scope_def with
scope_body =
{
scope_def.scope_body with
scope_body_expr = new_scope_body_expr;
};
})
new_scope_body_expr)
scopes
let new_next = Bindlib.bind_var (varf var_next) acc in
Bindlib.box_apply2
(fun scope_body_expr scope_next ->
ScopeDef
{
scope_def with
scope_body = { scope_def.scope_body with scope_body_expr };
scope_next;
})
new_scope_body_expr new_next)
~init:(Bindlib.box Nil) scopes
let untype_program prg =
{
prg with
scopes =
Bindlib.unbox
(map_exprs_in_scopes
~f:(fun e -> untype_expr e)
~varf:translate_var prg.scopes);
}
type 'm var = 'm expr Bindlib.var
type 'm vars = 'm expr Bindlib.mvar
let new_var s = Bindlib.new_var (fun x -> EVar x) s
module Var = struct
type t = expr Bindlib.var
type t = V : 'a expr Bindlib.var -> t
(* We use this trivial GADT to make the 'm parameter disappear under an
existential. It's fine for a use as keys only. (bindlib defines [any_var]
similarly but it's not exported) todo: add [@@ocaml.unboxed] once it's
possible through abstract types *)
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
let t v = V v
let get (V v) = Bindlib.copy_var v (fun x -> EVar x) (Bindlib.name_of v)
let compare (V x) (V y) = Bindlib.compare_vars x y
let eq (V x) (V y) = Bindlib.eq_vars x y
end
module VarMap = Map.Make (Var)
module VarSet = Set.Make (Var)
module VarMap = Map.Make (Var)
let rec free_vars_expr (e : expr Pos.marked) : VarSet.t =
match Pos.unmark e with
| EVar (v, _) -> VarSet.singleton v
let rec free_vars_expr (e : 'm marked_expr) : VarSet.t =
match Marked.unmark e with
| EVar v -> VarSet.singleton (Var.t v)
| ETuple (es, _) | EArray es ->
es |> List.map free_vars_expr |> List.fold_left VarSet.union VarSet.empty
| ETupleAccess (e1, _, _, _)
@ -411,85 +463,162 @@ let rec free_vars_expr (e : expr Pos.marked) : VarSet.t =
| EInj (e1, _, _, _) ->
free_vars_expr e1
| EApp (e1, es) | EMatch (e1, es, _) ->
e1 :: es |> List.map free_vars_expr
e1 :: es
|> List.map free_vars_expr
|> List.fold_left VarSet.union VarSet.empty
| EDefault (es, ejust, econs) ->
ejust :: econs :: es |> List.map free_vars_expr
ejust :: econs :: es
|> List.map free_vars_expr
|> List.fold_left VarSet.union VarSet.empty
| EOp _ | ELit _ -> VarSet.empty
| EIfThenElse (e1, e2, e3) ->
[e1; e2; e3] |> List.map free_vars_expr
[e1; e2; e3]
|> List.map free_vars_expr
|> List.fold_left VarSet.union VarSet.empty
| EAbs ((binder, _), _) ->
| EAbs (binder, _) ->
let vs, body = Bindlib.unmbind binder in
Array.fold_right VarSet.remove vs (free_vars_expr body)
Array.fold_right VarSet.remove (Array.map Var.t vs) (free_vars_expr body)
let rec free_vars_scope_body_expr (scope_lets : expr scope_body_expr) : VarSet.t
=
let rec free_vars_scope_body_expr (scope_lets : ('m expr, 'm) scope_body_expr) :
VarSet.t =
match scope_lets with
| Result e -> free_vars_expr e
| ScopeLet { scope_let_expr = e; scope_let_next = next; _ } ->
let v, body = Bindlib.unbind next in
VarSet.union (free_vars_expr e)
(VarSet.remove v (free_vars_scope_body_expr body))
(VarSet.remove (Var.t v) (free_vars_scope_body_expr body))
let free_vars_scope_body (scope_body : expr scope_body) : VarSet.t =
let free_vars_scope_body (scope_body : ('m expr, 'm) scope_body) : VarSet.t =
let { scope_body_expr = binder; _ } = scope_body in
let v, body = Bindlib.unbind binder in
VarSet.remove v (free_vars_scope_body_expr body)
VarSet.remove (Var.t v) (free_vars_scope_body_expr body)
let rec free_vars_scopes (scopes : expr scopes) : VarSet.t =
let rec free_vars_scopes (scopes : ('m expr, 'm) scopes) : VarSet.t =
match scopes with
| Nil -> VarSet.empty
| ScopeDef { scope_body = body; scope_next = next; _ } ->
let v, next = Bindlib.unbind next in
VarSet.union
(VarSet.remove v (free_vars_scopes next))
(VarSet.remove (Var.t v) (free_vars_scopes next))
(free_vars_scope_body body)
(* type vars = expr Bindlib.mvar *)
type vars = expr Bindlib.mvar
let make_var ((x, mark) : ('m expr Bindlib.var, 'm) marked) :
'm marked_expr Bindlib.box =
Bindlib.box_apply (fun x -> x, mark) (Bindlib.box_var x)
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)
type ('e, 'm) make_abs_sig =
'e Bindlib.mvar ->
('e, 'm) marked Bindlib.box ->
typ Marked.pos list ->
'm mark ->
('e, 'm) marked Bindlib.box
let make_abs
(xs : vars)
(e : expr Pos.marked Bindlib.box)
(pos_binder : Pos.t)
(taus : typ Pos.marked list)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply
(fun b -> EAbs ((b, pos_binder), taus), pos)
(Bindlib.bind_mvar xs e)
let (make_abs : ('m expr, 'm) make_abs_sig) =
fun xs e taus mark ->
Bindlib.box_apply (fun b -> EAbs (b, taus), mark) (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_app :
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
'm mark ->
'm marked_expr Bindlib.box =
fun e u mark ->
Bindlib.box_apply2 (fun e u -> EApp (e, u), mark) 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)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
make_app (make_abs (Array.of_list [x]) e2 pos [tau] pos) [e1] pos
type ('expr, 'm) make_let_in_sig =
'expr Bindlib.var ->
typ Marked.pos ->
('expr, 'm) marked Bindlib.box ->
('expr, 'm) marked Bindlib.box ->
Pos.t ->
('expr, 'm) marked Bindlib.box
let empty_thunked_term : expr Pos.marked =
let silent = Var.make ("_", Pos.no_pos) in
let map_mark
(type m)
(pos_f : Pos.t -> Pos.t)
(ty_f : marked_typ -> marked_typ)
(m : m mark) : m mark =
match m with
| Untyped { pos } -> Untyped { pos = pos_f pos }
| Typed { pos; ty } -> Typed { pos = pos_f pos; ty = ty_f ty }
| Inferring { pos; uf } ->
Inferring
{ pos = pos_f pos; uf = Infer.ast_to_typ (ty_f (Infer.typ_to_ast uf)) }
let resolve_inferring { uf; pos } = { ty = Infer.typ_to_ast uf; pos }
let map_mark2
(type m)
(pos_f : Pos.t -> Pos.t -> Pos.t)
(ty_f : typed -> typed -> marked_typ)
(m1 : m mark)
(m2 : m mark) : m mark =
match m1, m2 with
| Untyped m1, Untyped m2 -> Untyped { pos = pos_f m1.pos m2.pos }
| Typed m1, Typed m2 -> Typed { pos = pos_f m1.pos m2.pos; ty = ty_f m1 m2 }
| Inferring m1, Inferring m2 ->
Inferring
{
pos = pos_f m1.pos m2.pos;
uf =
Infer.ast_to_typ (ty_f (resolve_inferring m1) (resolve_inferring m2));
}
let fold_marks
(type m)
(pos_f : Pos.t list -> Pos.t)
(ty_f : typed list -> marked_typ)
(ms : m mark list) : m mark =
match ms with
| [] -> invalid_arg "Dcalc.Ast.fold_mark"
| Untyped _ :: _ as ms ->
Untyped { pos = pos_f (List.map (function Untyped { pos } -> pos) ms) }
| Typed _ :: _ ->
Typed
{
pos = pos_f (List.map (function Typed { pos; _ } -> pos) ms);
ty = ty_f (List.map (function Typed m -> m) ms);
}
| Inferring _ :: _ ->
Inferring
{
pos = pos_f (List.map (function Inferring { pos; _ } -> pos) ms);
uf =
Infer.ast_to_typ
(ty_f (List.map (function Inferring m -> resolve_inferring m) ms));
}
let empty_thunked_term mark : 'm marked_expr =
let silent = new_var "_" in
let pos = mark_pos mark in
Bindlib.unbox
(make_abs (Array.of_list [silent])
(Bindlib.box (ELit LEmptyError, Pos.no_pos))
Pos.no_pos
[TLit TUnit, Pos.no_pos]
Pos.no_pos)
(make_abs [| silent |]
(Bindlib.box (ELit LEmptyError, mark))
[TLit TUnit, pos]
(map_mark
(fun pos -> pos)
(fun ty ->
Marked.mark pos (TArrow (Marked.mark pos (TLit TUnit), ty)))
mark))
let is_value (e : expr Pos.marked) : bool =
match Pos.unmark e with ELit _ | EAbs _ | EOp _ -> true | _ -> false
let (make_let_in : ('m expr, 'm) make_let_in_sig) =
fun x tau e1 e2 pos ->
let m_e1 = Marked.get_mark (Bindlib.unbox e1) in
let m_e2 = Marked.get_mark (Bindlib.unbox e2) in
let m_abs =
map_mark2
(fun _ _ -> pos)
(fun m1 m2 -> Marked.mark pos (TArrow (m1.ty, m2.ty)))
m_e1 m_e2
in
make_app (make_abs [| x |] e2 [tau] m_abs) [e1] m_e2
let rec equal_typs (ty1 : typ Pos.marked) (ty2 : typ Pos.marked) : bool =
match Pos.unmark ty1, Pos.unmark ty2 with
let is_value (e : 'e marked_expr) : bool =
match Marked.unmark e with ELit _ | EAbs _ | EOp _ -> true | _ -> false
let rec equal_typs (ty1 : typ Marked.pos) (ty2 : typ Marked.pos) : bool =
match Marked.unmark ty1, Marked.unmark ty2 with
| TLit l1, TLit l2 -> l1 = l2
| TTuple (tys1, n1), TTuple (tys2, n2) -> n1 = n2 && equal_typs_list tys1 tys2
| TEnum (tys1, n1), TEnum (tys2, n2) -> n1 = n2 && equal_typs_list tys1 tys2
@ -498,7 +627,7 @@ let rec equal_typs (ty1 : typ Pos.marked) (ty2 : typ Pos.marked) : bool =
| TAny, TAny -> true
| _, _ -> false
and equal_typs_list (tys1 : typ Pos.marked list) (tys2 : typ Pos.marked list) :
and equal_typs_list (tys1 : typ Marked.pos list) (tys2 : typ Marked.pos list) :
bool =
List.length tys1 = List.length tys2
&& (* OCaml && operator short-circuits when a clause is false, we can safely
@ -525,9 +654,9 @@ let equal_ops (op1 : operator) (op2 : operator) : bool =
| Unop op1, Unop op2 -> equal_unops op1 op2
| _, _ -> false
let rec equal_exprs (e1 : expr Pos.marked) (e2 : expr Pos.marked) : bool =
match Pos.unmark e1, Pos.unmark e2 with
| EVar v1, EVar v2 -> Pos.unmark v1 = Pos.unmark v2
let rec equal_exprs (e1 : 'm marked_expr) (e2 : 'm marked_expr) : bool =
match Marked.unmark e1, Marked.unmark e2 with
| EVar v1, EVar v2 -> Bindlib.eq_vars v1 v2
| ETuple (es1, n1), ETuple (es2, n2) -> n1 = n2 && equal_exprs_list es1 es2
| ETupleAccess (e1, id1, n1, tys1), ETupleAccess (e2, id2, n2, tys2) ->
equal_exprs e1 e2 && id1 = id2 && n1 = n2 && equal_typs_list tys1 tys2
@ -540,50 +669,32 @@ let rec equal_exprs (e1 : expr Pos.marked) (e2 : expr Pos.marked) : bool =
| EAbs (b1, tys1), EAbs (b2, tys2) ->
equal_typs_list tys1 tys2
&&
let vars1, body1 = Bindlib.unmbind (Pos.unmark b1) in
let body2 =
Bindlib.msubst (Pos.unmark b2)
(Array.map (fun x -> EVar (x, Pos.no_pos)) vars1)
in
let vars1, body1 = Bindlib.unmbind b1 in
let body2 = Bindlib.msubst b2 (Array.map (fun x -> EVar x) vars1) in
equal_exprs body1 body2
| EAssert e1, EAssert e2 -> equal_exprs e1 e2
| EOp op1, EOp op2 -> equal_ops op1 op2
| EDefault (exc1, def1, cons1), EDefault (exc2, def2, cons2) ->
equal_exprs def1 def2 && equal_exprs cons1 cons2
equal_exprs def1 def2
&& equal_exprs cons1 cons2
&& equal_exprs_list exc1 exc2
| EIfThenElse (if1, then1, else1), EIfThenElse (if2, then2, else2) ->
equal_exprs if1 if2 && equal_exprs then1 then2 && equal_exprs else1 else2
| ErrorOnEmpty e1, ErrorOnEmpty e2 -> equal_exprs e1 e2
| _, _ -> false
and equal_exprs_list (es1 : expr Pos.marked list) (es2 : expr Pos.marked list) :
and equal_exprs_list (es1 : 'e marked_expr list) (es2 : 'm marked_expr list) :
bool =
List.length es1 = List.length es2
&& (* OCaml && operator short-circuits when a clause is false, we can safely
assume here that both lists have equal length *)
List.for_all (fun (x, y) -> equal_exprs x y) (List.combine es1 es2)
type 'expr make_let_in_sig =
'expr Bindlib.var ->
typ Pos.marked ->
'expr Pos.marked Bindlib.box ->
'expr Pos.marked Bindlib.box ->
Pos.t ->
'expr Pos.marked Bindlib.box
type 'expr make_abs_sig =
'expr Bindlib.mvar ->
'expr Pos.marked Bindlib.box ->
Pos.t ->
typ Pos.marked list ->
Pos.t ->
'expr Pos.marked Bindlib.box
let rec unfold_scope_body_expr
~(box_expr : 'expr box_expr_sig)
~(make_let_in : 'expr make_let_in_sig)
~(box_expr : ('expr, 'm) box_expr_sig)
~(make_let_in : ('expr, 'm) make_let_in_sig)
(ctx : decl_ctx)
(scope_let : 'expr scope_body_expr) : 'expr Pos.marked Bindlib.box =
(scope_let : ('expr, 'm) scope_body_expr) : ('expr, 'm) marked Bindlib.box =
match scope_let with
| Result e -> box_expr e
| ScopeLet
@ -600,29 +711,29 @@ let rec unfold_scope_body_expr
scope_let_pos
let build_whole_scope_expr
~(box_expr : 'expr box_expr_sig)
~(make_abs : 'expr make_abs_sig)
~(make_let_in : 'expr make_let_in_sig)
~(box_expr : ('expr, 'm) box_expr_sig)
~(make_abs : ('expr, 'm) make_abs_sig)
~(make_let_in : ('expr, 'm) make_let_in_sig)
(ctx : decl_ctx)
(body : 'expr scope_body)
(pos_scope : Pos.t) : 'expr Pos.marked Bindlib.box =
(body : ('expr, 'm) scope_body)
(mark_scope : 'm mark) : ('expr, 'm) marked Bindlib.box =
let var, body_expr = Bindlib.unbind body.scope_body_expr in
let body_expr = unfold_scope_body_expr ~box_expr ~make_let_in ctx body_expr in
make_abs (Array.of_list [var]) body_expr pos_scope
make_abs (Array.of_list [var]) body_expr
[
( TTuple
( List.map snd
(StructMap.find body.scope_body_input_struct ctx.ctx_structs),
Some body.scope_body_input_struct ),
pos_scope );
mark_pos mark_scope );
]
pos_scope
mark_scope
let build_scope_typ_from_sig
(ctx : decl_ctx)
(scope_input_struct_name : StructName.t)
(scope_return_struct_name : StructName.t)
(pos : Pos.t) : typ Pos.marked =
(pos : Pos.t) : typ Marked.pos =
let scope_sig = StructMap.find scope_input_struct_name ctx.ctx_structs in
let scope_return_typ =
StructMap.find scope_return_struct_name ctx.ctx_structs
@ -639,22 +750,27 @@ type 'expr scope_name_or_var =
| ScopeName of ScopeName.t
| ScopeVar of 'expr Bindlib.var
let get_scope_body_mark scope_body =
match snd (Bindlib.unbind scope_body.scope_body_expr) with
| Result e | ScopeLet { scope_let_expr = e; _ } -> Marked.get_mark e
let rec unfold_scopes
~(box_expr : 'expr box_expr_sig)
~(make_abs : 'expr make_abs_sig)
~(make_let_in : 'expr make_let_in_sig)
~(box_expr : ('expr, 'm) box_expr_sig)
~(make_abs : ('expr, 'm) make_abs_sig)
~(make_let_in : ('expr, 'm) make_let_in_sig)
(ctx : decl_ctx)
(s : 'expr scopes)
(main_scope : 'expr scope_name_or_var) : 'expr Pos.marked Bindlib.box =
(s : ('expr, 'm) scopes)
(mark : 'm mark)
(main_scope : 'expr scope_name_or_var) : ('expr, 'm) marked Bindlib.box =
match s with
| Nil -> (
match main_scope with
| ScopeVar v ->
Bindlib.box_apply (fun v -> v, Pos.no_pos) (Bindlib.box_var v)
| ScopeVar v -> Bindlib.box_apply (fun v -> v, mark) (Bindlib.box_var v)
| ScopeName _ -> failwith "should not happen")
| ScopeDef { scope_name; scope_body; scope_next } ->
let scope_var, scope_next = Bindlib.unbind scope_next in
let scope_pos = Pos.get_position (ScopeName.get_info scope_name) in
let scope_pos = Marked.get_mark (ScopeName.get_info scope_name) in
let scope_body_mark = get_scope_body_mark scope_body in
let main_scope =
match main_scope with
| ScopeVar v -> ScopeVar v
@ -666,16 +782,32 @@ let rec unfold_scopes
(build_scope_typ_from_sig ctx scope_body.scope_body_input_struct
scope_body.scope_body_output_struct scope_pos)
(build_whole_scope_expr ~box_expr ~make_abs ~make_let_in ctx scope_body
scope_pos)
(unfold_scopes ~box_expr ~make_abs ~make_let_in ctx scope_next main_scope)
scope_body_mark)
(unfold_scopes ~box_expr ~make_abs ~make_let_in ctx scope_next mark
main_scope)
scope_pos
let build_whole_program_expr (p : program) (main_scope : ScopeName.t) =
let rec find_scope name vars = function
| Nil -> raise Not_found
| ScopeDef { scope_name; scope_body; _ } when scope_name = name ->
List.rev vars, scope_body
| ScopeDef { scope_next; _ } ->
let var, next = Bindlib.unbind scope_next in
find_scope name (var :: vars) next
let build_whole_program_expr
~(box_expr : ('expr, 'm) box_expr_sig)
~(make_abs : ('expr, 'm) make_abs_sig)
~(make_let_in : ('expr, 'm) make_let_in_sig)
(p : ('expr, 'm) program_generic)
(main_scope : ScopeName.t) : ('expr, 'm) marked Bindlib.box =
let _, main_scope_body = find_scope main_scope [] p.scopes in
unfold_scopes ~box_expr ~make_abs ~make_let_in p.decl_ctx p.scopes
(get_scope_body_mark main_scope_body)
(ScopeName main_scope)
let rec expr_size (e : expr Pos.marked) : int =
match Pos.unmark e with
let rec expr_size (e : 'm marked_expr) : int =
match Marked.unmark e with
| EVar _ | ELit _ | EOp _ -> 1
| ETuple (args, _) | EArray args ->
List.fold_left (fun acc arg -> acc + expr_size arg) 1 args
@ -686,7 +818,7 @@ let rec expr_size (e : expr Pos.marked) : int =
expr_size e1 + 1
| EMatch (arg, args, _) | EApp (arg, args) ->
List.fold_left (fun acc arg -> acc + expr_size arg) (1 + expr_size arg) args
| EAbs ((binder, _), _) ->
| EAbs (binder, _) ->
let _, body = Bindlib.unmbind binder in
1 + expr_size body
| EIfThenElse (e1, e2, e3) -> 1 + expr_size e1 + expr_size e2 + expr_size e3
@ -696,9 +828,9 @@ let rec expr_size (e : expr Pos.marked) : int =
(1 + expr_size just + expr_size cons)
exceptions
let remove_logging_calls (e : expr Pos.marked) : expr Pos.marked Bindlib.box =
let remove_logging_calls (e : 'm marked_expr) : 'm marked_expr Bindlib.box =
let rec f () e =
match Pos.unmark e with
match Marked.unmark e with
| EApp ((EOp (Unop (Log _)), _), [arg]) -> map_expr () ~f arg
| _ -> map_expr () ~f e
in

430
compiler/dcalc/ast.mli
View File

@ -18,6 +18,7 @@
(** Abstract syntax tree of the default calculus intermediate representation *)
open Utils
module Runtime = Runtime_ocaml.Runtime
module ScopeName : Uid.Id with type info = Uid.MarkedString.info
module StructName : Uid.Id with type info = Uid.MarkedString.info
module StructFieldName : Uid.Id with type info = Uid.MarkedString.info
@ -32,12 +33,14 @@ module EnumMap : Map.S with type key = EnumName.t
type typ_lit = TBool | TUnit | TInt | TRat | TMoney | TDate | TDuration
type typ =
type marked_typ = typ Marked.pos
and typ =
| TLit of typ_lit
| TTuple of typ Pos.marked list * StructName.t option
| TEnum of typ Pos.marked list * EnumName.t
| TArrow of typ Pos.marked * typ Pos.marked
| TArray of typ Pos.marked
| TTuple of marked_typ list * StructName.t option
| TEnum of marked_typ list * EnumName.t
| TArrow of marked_typ * marked_typ
| TArray of marked_typ
| TAny
type date = Runtime.date
@ -94,43 +97,85 @@ type unop =
| Log of log_entry * Utils.Uid.MarkedString.info list
| Length
| IntToRat
| MoneyToRat
| RatToMoney
| GetDay
| GetMonth
| GetYear
| FirstDayOfMonth
| LastDayOfMonth
| RoundMoney
| RoundDecimal
type operator = Ternop of ternop | Binop of binop | Unop of unop
(** Contains some structures used for type inference *)
module Infer : sig
module Any : Utils.Uid.Id with type info = unit
type unionfind_typ = typ Marked.pos UnionFind.elem
(** We do not reuse {!type: 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. *)
and typ =
| TLit of typ_lit
| TArrow of unionfind_typ * unionfind_typ
| TTuple of unionfind_typ list * StructName.t option
| TEnum of unionfind_typ list * EnumName.t
| TArray of unionfind_typ
| TAny of Any.t
val typ_to_ast : unionfind_typ -> marked_typ
val ast_to_typ : marked_typ -> unionfind_typ
end
type untyped = { pos : Pos.t } [@@unboxed]
type typed = { pos : Pos.t; ty : marked_typ }
type inferring = { pos : Pos.t; uf : Infer.unionfind_typ }
(** The generic type of AST markings. Using a GADT allows functions to be
polymorphic in the marking, but still do transformations on types when
appropriate *)
type _ mark =
| Untyped : untyped -> untyped mark
| Typed : typed -> typed mark
| Inferring : inferring -> inferring mark
type ('a, 'm) marked = ('a, 'm mark) Marked.t
type 'm marked_expr = ('m expr, 'm) marked
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib}
library, based on higher-order abstract syntax*)
type expr =
| EVar of expr Bindlib.var Pos.marked
| ETuple of expr Pos.marked list * StructName.t option
and 'm expr =
| EVar of 'm expr Bindlib.var
| ETuple of 'm marked_expr list * StructName.t option
(** The [MarkedString.info] is the former struct field name*)
| ETupleAccess of
expr Pos.marked * int * StructName.t option * typ Pos.marked list
| ETupleAccess of 'm marked_expr * int * StructName.t option * marked_typ list
(** The [MarkedString.info] is the former struct field name *)
| EInj of expr Pos.marked * int * EnumName.t * typ Pos.marked list
| EInj of 'm marked_expr * int * EnumName.t * marked_typ list
(** The [MarkedString.info] is the former enum case name *)
| EMatch of expr Pos.marked * expr Pos.marked list * EnumName.t
| EMatch of 'm marked_expr * 'm marked_expr list * EnumName.t
(** The [MarkedString.info] is the former enum case name *)
| EArray of expr Pos.marked list
| EArray of 'm marked_expr list
| ELit of lit
| EAbs of
((expr, expr Pos.marked) Bindlib.mbinder[@opaque]) Pos.marked
* typ Pos.marked list
| EApp of expr Pos.marked * expr Pos.marked list
| EAssert of expr Pos.marked
(('m expr, 'm marked_expr) Bindlib.mbinder[@opaque]) * marked_typ list
| EApp of 'm marked_expr * 'm marked_expr list
| EAssert of 'm marked_expr
| EOp of operator
| EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
| ErrorOnEmpty of expr Pos.marked
| EDefault of 'm marked_expr list * 'm marked_expr * 'm marked_expr
| EIfThenElse of 'm marked_expr * 'm marked_expr * 'm marked_expr
| ErrorOnEmpty of 'm marked_expr
type struct_ctx = (StructFieldName.t * typ Pos.marked) list StructMap.t
type enum_ctx = (EnumConstructor.t * typ Pos.marked) list EnumMap.t
(** {3 Expression annotations ([Marked.t])} *)
type typed_expr = typed marked_expr
type struct_ctx = (StructFieldName.t * marked_typ) list StructMap.t
type enum_ctx = (EnumConstructor.t * marked_typ) list EnumMap.t
type decl_ctx = { ctx_enums : enum_ctx; ctx_structs : struct_ctx }
type binder = (expr, expr Pos.marked) Bindlib.binder
type 'm binder = ('m expr, 'm marked_expr) Bindlib.binder
(** This kind annotation signals that the let-binding respects a structural
invariant. These invariants concern the shape of the expression in the
@ -145,12 +190,12 @@ type scope_let_kind =
| DestructuringSubScopeResults (** [let s.x = result.x ]**)
| Assertion (** [let _ = assert e]*)
type 'expr scope_let = {
type ('expr, 'm) scope_let = {
scope_let_kind : scope_let_kind;
scope_let_typ : typ Utils.Pos.marked;
scope_let_expr : 'expr Utils.Pos.marked;
scope_let_next : ('expr, 'expr scope_body_expr) Bindlib.binder;
scope_let_pos : Utils.Pos.t;
scope_let_typ : marked_typ;
scope_let_expr : ('expr, 'm) marked;
scope_let_next : ('expr, ('expr, 'm) scope_body_expr) Bindlib.binder;
scope_let_pos : Pos.t;
}
(** This type is parametrized by the expression type so it can be reused in
later intermediate representations. *)
@ -158,110 +203,143 @@ type 'expr scope_let = {
(** A scope let-binding has all the information necessary to make a proper
let-binding expression, plus an annotation for the kind of the let-binding
that comes from the compilation of a {!module: Scopelang.Ast} statement. *)
and 'expr scope_body_expr =
| Result of 'expr Utils.Pos.marked
| ScopeLet of 'expr scope_let
and ('expr, 'm) scope_body_expr =
| Result of ('expr, 'm) marked
| ScopeLet of ('expr, 'm) scope_let
type 'expr scope_body = {
type ('expr, 'm) scope_body = {
scope_body_input_struct : StructName.t;
scope_body_output_struct : StructName.t;
scope_body_expr : ('expr, 'expr scope_body_expr) Bindlib.binder;
scope_body_expr : ('expr, ('expr, 'm) scope_body_expr) Bindlib.binder;
}
(** Instead of being a single expression, we give a little more ad-hoc structure
to the scope body by decomposing it in an ordered list of let-bindings, and
a result expression that uses the let-binded variables. The first binder is
the argument of type [scope_body_input_struct]. *)
type 'expr scope_def = {
type ('expr, 'm) scope_def = {
scope_name : ScopeName.t;
scope_body : 'expr scope_body;
scope_next : ('expr, 'expr scopes) Bindlib.binder;
scope_body : ('expr, 'm) scope_body;
scope_next : ('expr, ('expr, 'm) scopes) Bindlib.binder;
}
(** Finally, we do the same transformation for the whole program for the kinded
lets. This permit us to use bindlib variables for scopes names. *)
and 'a scopes = Nil | ScopeDef of 'a scope_def
and ('expr, 'm) scopes = Nil | ScopeDef of ('expr, 'm) scope_def
type program = { decl_ctx : decl_ctx; scopes : expr scopes }
type ('expr, 'm) program_generic = {
decl_ctx : decl_ctx;
scopes : ('expr, 'm) scopes;
}
type 'm program = ('m expr, 'm) program_generic
(** {1 Helpers} *)
(** {2 Boxed constructors}*)
(** {2 Manipulation of marks} *)
val evar : expr Bindlib.var -> Pos.t -> expr Pos.marked Bindlib.box
val no_mark : 'm mark -> 'm mark
val mark_pos : 'm mark -> Pos.t
val pos : ('a, 'm) marked -> Pos.t
val ty : ('a, typed) marked -> marked_typ
val with_ty : marked_typ -> ('a, 'm) marked -> ('a, typed) marked
(** All the following functions will resolve the types if called on an
[Inferring] type *)
val map_mark :
(Pos.t -> Pos.t) -> (marked_typ -> marked_typ) -> 'm mark -> 'm mark
val map_mark2 :
(Pos.t -> Pos.t -> Pos.t) ->
(typed -> typed -> marked_typ) ->
'm mark ->
'm mark ->
'm mark
val fold_marks :
(Pos.t list -> Pos.t) -> (typed list -> marked_typ) -> 'm mark list -> 'm mark
val get_scope_body_mark : ('expr, 'm) scope_body -> 'm mark
val untype_expr : 'm marked_expr -> untyped marked_expr Bindlib.box
val untype_program : 'm program -> untyped program
(** {2 Boxed constructors} *)
val evar : 'm expr Bindlib.var -> 'm mark -> 'm marked_expr Bindlib.box
val etuple :
expr Pos.marked Bindlib.box list ->
'm marked_expr Bindlib.box list ->
StructName.t option ->
Pos.t ->
expr Pos.marked Bindlib.box
'm mark ->
'm marked_expr Bindlib.box
val etupleaccess :
expr Pos.marked Bindlib.box ->
'm marked_expr Bindlib.box ->
int ->
StructName.t option ->
typ Pos.marked list ->
Pos.t ->
expr Pos.marked Bindlib.box
marked_typ list ->
'm mark ->
'm marked_expr Bindlib.box
val einj :
expr Pos.marked Bindlib.box ->
'm marked_expr Bindlib.box ->
int ->
EnumName.t ->
typ Pos.marked list ->
Pos.t ->
expr Pos.marked Bindlib.box
marked_typ list ->
'm mark ->
'm marked_expr Bindlib.box
val ematch :
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box list ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
EnumName.t ->
Pos.t ->
expr Pos.marked Bindlib.box
'm mark ->
'm marked_expr Bindlib.box
val earray :
expr Pos.marked Bindlib.box list -> Pos.t -> expr Pos.marked Bindlib.box
'm marked_expr Bindlib.box list -> 'm mark -> 'm marked_expr Bindlib.box
val elit : lit -> Pos.t -> expr Pos.marked Bindlib.box
val elit : lit -> 'm mark -> 'm marked_expr Bindlib.box
val eabs :
(expr, expr Pos.marked) Bindlib.mbinder Bindlib.box ->
Pos.t ->
typ Pos.marked list ->
Pos.t ->
expr Pos.marked Bindlib.box
('m expr, 'm marked_expr) Bindlib.mbinder Bindlib.box ->
marked_typ list ->
'm mark ->
'm marked_expr Bindlib.box
val eapp :
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box list ->
Pos.t ->
expr Pos.marked Bindlib.box
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
'm mark ->
'm marked_expr Bindlib.box
val eassert :
expr Pos.marked Bindlib.box -> Pos.t -> expr Pos.marked Bindlib.box
'm marked_expr Bindlib.box -> 'm mark -> 'm marked_expr Bindlib.box
val eop : operator -> Pos.t -> expr Pos.marked Bindlib.box
val eop : operator -> 'm mark -> 'm marked_expr Bindlib.box
val edefault :
expr Pos.marked Bindlib.box list ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box ->
Pos.t ->
expr Pos.marked Bindlib.box
'm marked_expr Bindlib.box list ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm mark ->
'm marked_expr Bindlib.box
val eifthenelse :
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box ->
Pos.t ->
expr Pos.marked Bindlib.box
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm mark ->
'm marked_expr Bindlib.box
val eerroronempty :
expr Pos.marked Bindlib.box -> Pos.t -> expr Pos.marked Bindlib.box
'm marked_expr Bindlib.box -> 'm mark -> 'm marked_expr Bindlib.box
val box_expr : expr Pos.marked -> expr Pos.marked Bindlib.box
type ('expr, 'm) box_expr_sig =
('expr, 'm) marked -> ('expr, 'm) marked Bindlib.box
type 'expr box_expr_sig = 'expr Pos.marked -> 'expr Pos.marked Bindlib.box
val box_expr : ('m expr, 'm) box_expr_sig
(**{2 Program traversal}*)
@ -270,9 +348,9 @@ type 'expr box_expr_sig = 'expr Pos.marked -> 'expr Pos.marked Bindlib.box
val map_expr :
'a ->
f:('a -> expr Pos.marked -> expr Pos.marked Bindlib.box) ->
expr Pos.marked ->
expr Pos.marked Bindlib.box
f:('a -> 'm1 marked_expr -> 'm2 marked_expr Bindlib.box) ->
('m1 expr, 'm2 mark) Marked.t ->
'm2 marked_expr Bindlib.box
(** If you want to apply a map transform to an expression, you can save up
writing a painful match over all the cases of the AST. For instance, if you
want to remove all errors on empty, you can write
@ -280,7 +358,7 @@ val map_expr :
{[
let remove_error_empty =
let rec f () e =
match Pos.unmark e with
match Marked.unmark e with
| ErrorOnEmpty e1 -> map_expr () f e1
| _ -> map_expr () f e
in
@ -290,10 +368,21 @@ val map_expr :
The first argument of map_expr is an optional context that you can carry
around during your map traversal. *)
val map_expr_top_down :
f:('m1 marked_expr -> ('m1 expr, 'm2 mark) Marked.t) ->
'm1 marked_expr ->
'm2 marked_expr Bindlib.box
(** Recursively applies [f] to the nodes of the expression tree. The type
returned by [f] is hybrid since the mark at top-level has been rewritten,
but not yet the marks in the subtrees. *)
val map_expr_marks :
f:('m1 mark -> 'm2 mark) -> 'm1 marked_expr -> 'm2 marked_expr Bindlib.box
val fold_left_scope_lets :
f:('a -> 'expr scope_let -> 'expr Bindlib.var -> 'a) ->
f:('a -> ('expr, 'm) scope_let -> 'expr Bindlib.var -> 'a) ->
init:'a ->
'expr scope_body_expr ->
('expr, 'm) scope_body_expr ->
'a
(** Usage:
[fold_left_scope_lets ~f:(fun acc scope_let scope_let_var -> ...) ~init scope_lets],
@ -301,9 +390,9 @@ val fold_left_scope_lets :
scope lets to be examined. *)
val fold_right_scope_lets :
f:('expr scope_let -> 'expr Bindlib.var -> 'a -> 'a) ->
init:('expr Pos.marked -> 'a) ->
'expr scope_body_expr ->
f:(('expr1, 'm1) scope_let -> 'expr1 Bindlib.var -> 'a -> 'a) ->
init:(('expr1, 'm1) marked -> 'a) ->
('expr1, 'm1) scope_body_expr ->
'a
(** Usage:
[fold_right_scope_lets ~f:(fun scope_let scope_let_var acc -> ...) ~init scope_lets],
@ -311,14 +400,15 @@ val fold_right_scope_lets :
scope lets to be examined (which are before in the program order). *)
val map_exprs_in_scope_lets :
f:('expr Pos.marked -> 'expr Pos.marked Bindlib.box) ->
'expr scope_body_expr ->
'expr scope_body_expr Bindlib.box
f:(('expr1, 'm1) marked -> ('expr2, 'm2) marked Bindlib.box) ->
varf:('expr1 Bindlib.var -> 'expr2 Bindlib.var) ->
('expr1, 'm1) scope_body_expr ->
('expr2, 'm2) scope_body_expr Bindlib.box
val fold_left_scope_defs :
f:('a -> 'expr scope_def -> 'expr Bindlib.var -> 'a) ->
f:('a -> ('expr1, 'm1) scope_def -> 'expr1 Bindlib.var -> 'a) ->
init:'a ->
'expr scopes ->
('expr1, 'm1) scopes ->
'a
(** Usage:
[fold_left_scope_defs ~f:(fun acc scope_def scope_var -> ...) ~init scope_def],
@ -326,9 +416,9 @@ val fold_left_scope_defs :
be examined. *)
val fold_right_scope_defs :
f:('expr scope_def -> 'expr Bindlib.var -> 'a -> 'a) ->
f:(('expr1, 'm1) scope_def -> 'expr1 Bindlib.var -> 'a -> 'a) ->
init:'a ->
'expr scopes ->
('expr1, 'm1) scopes ->
'a
(** Usage:
[fold_right_scope_defs ~f:(fun scope_def scope_var acc -> ...) ~init scope_def],
@ -336,96 +426,99 @@ val fold_right_scope_defs :
be examined (which are before in the program order). *)
val map_scope_defs :
f:('expr scope_def -> 'expr scope_def Bindlib.box) ->
'expr scopes ->
'expr scopes Bindlib.box
f:(('expr, 'm) scope_def -> ('expr, 'm) scope_def Bindlib.box) ->
('expr, 'm) scopes ->
('expr, 'm) scopes Bindlib.box
val map_exprs_in_scopes :
f:('expr Pos.marked -> 'expr Pos.marked Bindlib.box) ->
'expr scopes ->
'expr scopes Bindlib.box
f:(('expr1, 'm1) marked -> ('expr2, 'm2) marked Bindlib.box) ->
varf:('expr1 Bindlib.var -> 'expr2 Bindlib.var) ->
('expr1, 'm1) scopes ->
('expr2, 'm2) scopes Bindlib.box
(** This is the main map visitor for all the expressions inside all the scopes
of the program. *)
(** {2 Variables}*)
(** {2 Variables} *)
type 'm var = 'm expr Bindlib.var
val new_var : string -> 'm var
val translate_var : 'm1 var -> 'm2 var
(** used to convert between e.g. [untyped expr var] into a [typed expr var] *)
module Var : sig
type t = expr Bindlib.var
type t
val t : 'm expr Bindlib.var -> t
(** Hides the marking type parameter annotation behind an existential type so
that variables can be stored in non-polymorphic sets and maps *)
val get : t -> 'm expr Bindlib.var
(** Be careful with this, it breaks the type abstraction by casting the
existential type annotation. See [!Bindlib.copy_var] for more detail. *)
val make : string Pos.marked -> t
val compare : t -> t -> int
val eq : t -> t -> bool
end
module VarMap : Map.S with type key = Var.t
module VarSet : Set.S with type elt = Var.t
val free_vars_expr : expr Pos.marked -> VarSet.t
val free_vars_scope_body_expr : expr scope_body_expr -> VarSet.t
val free_vars_scope_body : expr scope_body -> VarSet.t
val free_vars_scopes : expr scopes -> VarSet.t
val free_vars_expr : 'm marked_expr -> VarSet.t
val free_vars_scope_body_expr : ('m expr, 'm) scope_body_expr -> VarSet.t
val free_vars_scope_body : ('m expr, 'm) scope_body -> VarSet.t
val free_vars_scopes : ('m expr, 'm) scopes -> VarSet.t
type vars = expr Bindlib.mvar
(* type vars = expr Bindlib.mvar *)
(** {2 Boxed term constructors}*)
val make_var : ('m var, 'm) marked -> 'm marked_expr Bindlib.box
val make_var : Var.t Pos.marked -> expr Pos.marked Bindlib.box
(** {2 Boxed term constructors} *)
val make_abs :
vars ->
expr Pos.marked Bindlib.box ->
Pos.t ->
typ Pos.marked list ->
Pos.t ->
expr Pos.marked Bindlib.box
type ('e, 'm) make_abs_sig =
'e Bindlib.mvar ->
('e, 'm) marked Bindlib.box ->
marked_typ list ->
'm mark ->
('e, 'm) marked Bindlib.box
val make_abs : ('m expr, 'm) make_abs_sig
val make_app :
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box list ->
Pos.t ->
expr Pos.marked Bindlib.box
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
'm mark ->
'm marked_expr Bindlib.box
val make_let_in :
Var.t ->
typ Pos.marked ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box ->
type ('expr, 'm) make_let_in_sig =
'expr Bindlib.var ->
marked_typ ->
('expr, 'm) marked Bindlib.box ->
('expr, 'm) marked Bindlib.box ->
Pos.t ->
expr Pos.marked Bindlib.box
('expr, 'm) marked Bindlib.box
val make_let_in : ('m expr, 'm) make_let_in_sig
(**{2 Other}*)
val empty_thunked_term : expr Pos.marked
val is_value : expr Pos.marked -> bool
val empty_thunked_term : 'm mark -> 'm marked_expr
val is_value : 'm marked_expr -> bool
val equal_exprs : expr Pos.marked -> expr Pos.marked -> bool
val equal_exprs : 'm marked_expr -> 'm marked_expr -> bool
(** Determines if two expressions are equal, omitting their position information *)
(** {1 AST manipulation helpers}*)
type 'expr make_let_in_sig =
'expr Bindlib.var ->
typ Pos.marked ->
'expr Pos.marked Bindlib.box ->
'expr Pos.marked Bindlib.box ->
Pos.t ->
'expr Pos.marked Bindlib.box
type 'expr make_abs_sig =
'expr Bindlib.mvar ->
'expr Pos.marked Bindlib.box ->
Pos.t ->
typ Pos.marked list ->
Pos.t ->
'expr Pos.marked Bindlib.box
val build_whole_scope_expr :
box_expr:'expr box_expr_sig ->
make_abs:'expr make_abs_sig ->
make_let_in:'expr make_let_in_sig ->
box_expr:('expr, 'm) box_expr_sig ->
make_abs:('expr, 'm) make_abs_sig ->
make_let_in:('expr, 'm) make_let_in_sig ->
decl_ctx ->
'expr scope_body ->
Pos.t ->
'expr Pos.marked Bindlib.box
('expr, 'm) scope_body ->
'm mark ->
('expr, 'm) marked Bindlib.box
(** Usage: [build_whole_scope_expr ctx body scope_position] where
[scope_position] corresponds to the line of the scope declaration for
instance. *)
@ -435,23 +528,34 @@ type 'expr scope_name_or_var =
| ScopeVar of 'expr Bindlib.var
val unfold_scopes :
box_expr:'expr box_expr_sig ->
make_abs:'expr make_abs_sig ->
make_let_in:'expr make_let_in_sig ->
box_expr:('expr, 'm) box_expr_sig ->
make_abs:('expr, 'm) make_abs_sig ->
make_let_in:('expr, 'm) make_let_in_sig ->
decl_ctx ->
'expr scopes ->
('expr, 'm) scopes ->
'm mark ->
'expr scope_name_or_var ->
'expr Pos.marked Bindlib.box
('expr, 'm) marked Bindlib.box
val build_whole_program_expr :
program -> ScopeName.t -> expr Pos.marked Bindlib.box
box_expr:('expr, 'm) box_expr_sig ->
make_abs:('expr, 'm) make_abs_sig ->
make_let_in:('expr, 'm) make_let_in_sig ->
('expr, 'm) program_generic ->
ScopeName.t ->
('expr, 'm) marked Bindlib.box
(** Usage: [build_whole_program_expr program main_scope] builds an expression
corresponding to the main program and returning the main scope as a
function. *)
val expr_size : expr Pos.marked -> int
val expr_size : 'm marked_expr -> int
(** Used by the optimizer to know when to stop *)
val remove_logging_calls : expr Pos.marked -> expr Pos.marked Bindlib.box
val remove_logging_calls : 'm marked_expr -> 'm marked_expr Bindlib.box
(** Removes all calls to [Log] unary operators in the AST, replacing them by
their argument. *)
val build_scope_typ_from_sig :
decl_ctx -> StructName.t -> StructName.t -> Pos.t -> typ Marked.pos
(** [build_scope_typ_from_sig ctx in_struct out_struct pos] builds the arrow
type for the specified scope *)

2
compiler/dcalc/dune
View File

@ -1,7 +1,7 @@
(library
(name dcalc)
(public_name catala.dcalc)
(libraries bindlib unionFind utils re camomile runtime)
(libraries bindlib unionFind utils re ubase catala.runtime_ocaml)
(preprocess
(pps visitors.ppx)))

731
compiler/dcalc/interpreter.ml
View File

@ -18,11 +18,12 @@
open Utils
module A = Ast
module Runtime = Runtime_ocaml.Runtime
(** {1 Helpers} *)
let is_empty_error (e : A.expr Pos.marked) : bool =
match Pos.unmark e with ELit LEmptyError -> true | _ -> false
let is_empty_error (e : 'm A.marked_expr) : bool =
match Marked.unmark e with ELit LEmptyError -> true | _ -> false
let log_indent = ref 0
@ -30,390 +31,384 @@ let log_indent = ref 0
let rec evaluate_operator
(ctx : Ast.decl_ctx)
(op : A.operator Pos.marked)
(args : A.expr Pos.marked list) : A.expr Pos.marked =
(op : A.operator)
(pos : Pos.t)
(args : 'm A.marked_expr list) : 'm A.expr =
(* Try to apply [div] and if a [Division_by_zero] exceptions is catched, use
[op] to raise multispanned errors. *)
let apply_div_or_raise_err (div : unit -> A.expr) (op : A.operator Pos.marked)
: A.expr =
let apply_div_or_raise_err (div : unit -> 'm A.expr) : 'm A.expr =
try div ()
with Division_by_zero ->
Errors.raise_multispanned_error
[
Some "The division operator:", Pos.get_position op;
Some "The null denominator:", Pos.get_position (List.nth args 1);
Some "The division operator:", pos;
Some "The null denominator:", Ast.pos (List.nth args 1);
]
"division by zero at runtime"
in
let get_binop_args_pos (args : (A.expr * Pos.t) list) :
(string option * Pos.t) list =
[
None, Pos.get_position (List.nth args 0);
None, Pos.get_position (List.nth args 1);
]
let get_binop_args_pos = function
| (arg0 :: arg1 :: _ : 'm A.marked_expr list) ->
[None, Ast.pos arg0; None, Ast.pos arg1]
| _ -> assert false
in
(* Try to apply [cmp] and if a [UncomparableDurations] exceptions is catched,
use [args] to raise multispanned errors. *)
let apply_cmp_or_raise_err
(cmp : unit -> A.expr)
(args : (A.expr * Pos.t) list) : A.expr =
(cmp : unit -> 'm A.expr)
(args : 'm A.marked_expr list) : 'm A.expr =
try cmp ()
with Runtime.UncomparableDurations ->
Errors.raise_multispanned_error (get_binop_args_pos args)
"Cannot compare together durations that cannot be converted to a \
precise number of days"
in
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' ->
match op, List.map Marked.unmark args with
| A.Ternop A.Fold, [_f; _init; EArray es] ->
Marked.unmark
(List.fold_left
(fun acc e' ->
evaluate_expr ctx
(Marked.same_mark_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.Xor, [ELit (LBool b1); ELit (LBool b2)] ->
A.ELit (LBool (b1 <> b2))
| A.Binop (A.Add KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LInt Runtime.(i1 +! i2))
| A.Binop (A.Sub KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LInt Runtime.(i1 -! i2))
| A.Binop (A.Mult KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LInt Runtime.(i1 *! i2))
| A.Binop (A.Div KInt), [ELit (LInt i1); ELit (LInt i2)] ->
apply_div_or_raise_err (fun _ -> A.ELit (LInt Runtime.(i1 /! i2)))
| A.Binop (A.Add KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LRat Runtime.(i1 +& i2))
| A.Binop (A.Sub KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LRat Runtime.(i1 -& i2))
| A.Binop (A.Mult KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LRat Runtime.(i1 *& i2))
| A.Binop (A.Div KRat), [ELit (LRat i1); ELit (LRat i2)] ->
apply_div_or_raise_err (fun _ -> A.ELit (LRat Runtime.(i1 /& i2)))
| A.Binop (A.Add KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LMoney Runtime.(m1 +$ m2))
| A.Binop (A.Sub KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LMoney Runtime.(m1 -$ m2))
| A.Binop (A.Mult KMoney), [ELit (LMoney m1); ELit (LRat m2)] ->
A.ELit (LMoney Runtime.(m1 *$ m2))
| A.Binop (A.Div KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
apply_div_or_raise_err (fun _ -> A.ELit (LRat Runtime.(m1 /$ m2)))
| A.Binop (A.Add KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
A.ELit (LDuration Runtime.(d1 +^ d2))
| A.Binop (A.Sub KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
A.ELit (LDuration Runtime.(d1 -^ d2))
| A.Binop (A.Sub KDate), [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LDuration Runtime.(d1 -@ d2))
| A.Binop (A.Add KDate), [ELit (LDate d1); ELit (LDuration d2)] ->
A.ELit (LDate Runtime.(d1 +@ d2))
| A.Binop (A.Div KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
apply_div_or_raise_err (fun _ ->
try A.ELit (LRat Runtime.(d1 /^ d2))
with Runtime.IndivisableDurations ->
Errors.raise_multispanned_error (get_binop_args_pos args)
"Cannot divide durations that cannot be converted to a precise \
number of days")
| A.Binop (A.Mult KDuration), [ELit (LDuration d1); ELit (LInt i1)] ->
A.ELit (LDuration Runtime.(d1 *^ i1))
| A.Binop (A.Lt KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LBool Runtime.(i1 <! i2))
| A.Binop (A.Lte KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LBool Runtime.(i1 <=! i2))
| A.Binop (A.Gt KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LBool Runtime.(i1 >! i2))
| A.Binop (A.Gte KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LBool Runtime.(i1 >=! i2))
| A.Binop (A.Lt KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LBool Runtime.(i1 <& i2))
| A.Binop (A.Lte KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LBool Runtime.(i1 <=& i2))
| A.Binop (A.Gt KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LBool Runtime.(i1 >& i2))
| A.Binop (A.Gte KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LBool Runtime.(i1 >=& i2))
| A.Binop (A.Lt KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LBool Runtime.(m1 <$ m2))
| A.Binop (A.Lte KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LBool Runtime.(m1 <=$ m2))
| A.Binop (A.Gt KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LBool Runtime.(m1 >$ m2))
| A.Binop (A.Gte KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LBool Runtime.(m1 >=$ m2))
| A.Binop (A.Lt KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 <^ d2))) args
| A.Binop (A.Lte KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 <=^ d2))) args
| A.Binop (A.Gt KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 >^ d2))) args
| A.Binop (A.Gte KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 >=^ d2))) args
| A.Binop (A.Lt KDate), [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LBool Runtime.(d1 <@ d2))
| A.Binop (A.Lte KDate), [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LBool Runtime.(d1 <=@ d2))
| A.Binop (A.Gt KDate), [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LBool Runtime.(d1 >@ d2))
| A.Binop (A.Gte KDate), [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LBool Runtime.(d1 >=@ d2))
| A.Binop A.Eq, [ELit LUnit; ELit LUnit] -> A.ELit (LBool true)
| A.Binop A.Eq, [ELit (LDuration d1); ELit (LDuration d2)] ->
A.ELit (LBool Runtime.(d1 =^ d2))
| A.Binop A.Eq, [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LBool Runtime.(d1 =@ d2))
| A.Binop A.Eq, [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LBool Runtime.(m1 =$ m2))
| A.Binop A.Eq, [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LBool Runtime.(i1 =& i2))
| A.Binop A.Eq, [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LBool Runtime.(i1 =! i2))
| A.Binop A.Eq, [ELit (LBool b1); ELit (LBool b2)] -> A.ELit (LBool (b1 = b2))
| A.Binop A.Eq, [EArray es1; EArray es2] ->
A.ELit
(LBool
(try
List.for_all2
(fun e1 e2 ->
match evaluate_operator ctx op pos [e1; e2] with
| A.ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
es1 es2
with Invalid_argument _ -> false))
| A.Binop A.Eq, [ETuple (es1, s1); ETuple (es2, s2)] ->
A.ELit
(LBool
(try
s1 = s2
&& List.for_all2
(fun e1 e2 ->
match evaluate_operator ctx op pos [e1; e2] with
| A.ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
es1 es2
with Invalid_argument _ -> false))
| A.Binop A.Eq, [EInj (e1, i1, en1, _ts1); EInj (e2, i2, en2, _ts2)] ->
A.ELit
(LBool
(try
en1 = en2
&& i1 = i2
&&
match evaluate_operator ctx op pos [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 evaluate_operator ctx (A.Binop A.Eq) pos args with
| A.ELit (A.LBool b) -> A.ELit (A.LBool (not b))
| _ -> assert false (*should not happen *))
| A.Binop A.Concat, [A.EArray es1; A.EArray es2] -> A.EArray (es1 @ es2)
| A.Binop A.Map, [_; A.EArray es] ->
A.EArray
(List.map
(fun e' ->
evaluate_expr ctx
(Marked.same_mark_as (A.EApp (List.nth args 0, [e'])) e'))
es)
| A.Binop A.Filter, [_; A.EArray es] ->
A.EArray
(List.filter
(fun e' ->
match
evaluate_expr ctx
(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.Xor, [ELit (LBool b1); ELit (LBool b2)] ->
A.ELit (LBool (b1 <> b2))
| A.Binop (A.Add KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LInt Runtime.(i1 +! i2))
| A.Binop (A.Sub KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LInt Runtime.(i1 -! i2))
| A.Binop (A.Mult KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LInt Runtime.(i1 *! i2))
| A.Binop (A.Div KInt), [ELit (LInt i1); ELit (LInt i2)] ->
apply_div_or_raise_err (fun _ -> A.ELit (LInt Runtime.(i1 /! i2))) op
| A.Binop (A.Add KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LRat Runtime.(i1 +& i2))
| A.Binop (A.Sub KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LRat Runtime.(i1 -& i2))
| A.Binop (A.Mult KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LRat Runtime.(i1 *& i2))
| A.Binop (A.Div KRat), [ELit (LRat i1); ELit (LRat i2)] ->
apply_div_or_raise_err (fun _ -> A.ELit (LRat Runtime.(i1 /& i2))) op
| A.Binop (A.Add KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LMoney Runtime.(m1 +$ m2))
| A.Binop (A.Sub KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LMoney Runtime.(m1 -$ m2))
| A.Binop (A.Mult KMoney), [ELit (LMoney m1); ELit (LRat m2)] ->
A.ELit (LMoney Runtime.(m1 *$ m2))
| A.Binop (A.Div KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
apply_div_or_raise_err (fun _ -> A.ELit (LRat Runtime.(m1 /$ m2))) op
| A.Binop (A.Add KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
A.ELit (LDuration Runtime.(d1 +^ d2))
| A.Binop (A.Sub KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
A.ELit (LDuration Runtime.(d1 -^ d2))
| A.Binop (A.Sub KDate), [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LDuration Runtime.(d1 -@ d2))
| A.Binop (A.Add KDate), [ELit (LDate d1); ELit (LDuration d2)] ->
A.ELit (LDate Runtime.(d1 +@ d2))
(* | A.Binop (A.Div KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
* apply_div_or_raise_err
* (fun _ ->
* try A.ELit (LRat Runtime.(d1 /^ d2))
* with Runtime.IndivisableDurations ->
* Errors.raise_multispanned_error (get_binop_args_pos args)
* "Cannot divide durations that cannot be converted to a precise \
* number of days")
* op *)
| A.Binop (A.Mult KDuration), [ELit (LDuration d1); ELit (LInt i1)] ->
A.ELit (LDuration Runtime.(d1 *^ i1))
| A.Binop (A.Lt KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LBool Runtime.(i1 <! i2))
| A.Binop (A.Lte KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LBool Runtime.(i1 <=! i2))
| A.Binop (A.Gt KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LBool Runtime.(i1 >! i2))
| A.Binop (A.Gte KInt), [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LBool Runtime.(i1 >=! i2))
| A.Binop (A.Lt KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LBool Runtime.(i1 <& i2))
| A.Binop (A.Lte KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LBool Runtime.(i1 <=& i2))
| A.Binop (A.Gt KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LBool Runtime.(i1 >& i2))
| A.Binop (A.Gte KRat), [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LBool Runtime.(i1 >=& i2))
| A.Binop (A.Lt KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LBool Runtime.(m1 <$ m2))
| A.Binop (A.Lte KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LBool Runtime.(m1 <=$ m2))
| A.Binop (A.Gt KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LBool Runtime.(m1 >$ m2))
| A.Binop (A.Gte KMoney), [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LBool Runtime.(m1 >=$ m2))
| A.Binop (A.Lt KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 <^ d2))) args
| A.Binop (A.Lte KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 <=^ d2))) args
| A.Binop (A.Gt KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 >^ d2))) args
| A.Binop (A.Gte KDuration), [ELit (LDuration d1); ELit (LDuration d2)] ->
apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 >=^ d2))) args
| A.Binop (A.Lt KDate), [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LBool Runtime.(d1 <@ d2))
| A.Binop (A.Lte KDate), [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LBool Runtime.(d1 <=@ d2))
| A.Binop (A.Gt KDate), [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LBool Runtime.(d1 >@ d2))
| A.Binop (A.Gte KDate), [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LBool Runtime.(d1 >=@ d2))
| A.Binop A.Eq, [ELit LUnit; ELit LUnit] -> A.ELit (LBool true)
| A.Binop A.Eq, [ELit (LDuration d1); ELit (LDuration d2)] ->
A.ELit (LBool Runtime.(d1 =^ d2))
| A.Binop A.Eq, [ELit (LDate d1); ELit (LDate d2)] ->
A.ELit (LBool Runtime.(d1 =@ d2))
| A.Binop A.Eq, [ELit (LMoney m1); ELit (LMoney m2)] ->
A.ELit (LBool Runtime.(m1 =$ m2))
| A.Binop A.Eq, [ELit (LRat i1); ELit (LRat i2)] ->
A.ELit (LBool Runtime.(i1 =& i2))
| A.Binop A.Eq, [ELit (LInt i1); ELit (LInt i2)] ->
A.ELit (LBool Runtime.(i1 =! i2))
| A.Binop A.Eq, [ELit (LBool b1); ELit (LBool b2)] ->
A.ELit (LBool (b1 = b2))
| A.Binop A.Eq, [EArray es1; EArray es2] ->
A.ELit
(LBool
(try
List.for_all2
(fun e1 e2 ->
match Pos.unmark (evaluate_operator ctx op [e1; e2]) with
| A.ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
es1 es2
with Invalid_argument _ -> false))
| A.Binop A.Eq, [ETuple (es1, s1); ETuple (es2, s2)] ->
A.ELit
(LBool
(try
s1 = s2
&& List.for_all2
(fun e1 e2 ->
match Pos.unmark (evaluate_operator ctx op [e1; e2]) with
| A.ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
es1 es2
with Invalid_argument _ -> false))
| A.Binop A.Eq, [EInj (e1, i1, en1, _ts1); EInj (e2, i2, en2, _ts2)] ->
A.ELit
(LBool
(try
en1 = en2 && i1 = i2
&&
match Pos.unmark (evaluate_operator ctx op [e1; e2]) with
| A.ELit (LBool b) -> b
| _ -> assert false
(* should not happen *)
with Invalid_argument _ -> false))
| A.Binop A.Eq, [_; _] ->
A.ELit (LBool false) (* comparing anything else return false *)
| A.Binop A.Neq, [_; _] -> (
match
Pos.unmark
(evaluate_operator ctx (Pos.same_pos_as (A.Binop A.Eq) op) args)
with
| A.ELit (A.LBool b) -> A.ELit (A.LBool (not b))
| _ -> assert false (*should not happen *))
| A.Binop A.Concat, [A.EArray es1; A.EArray es2] -> A.EArray (es1 @ es2)
| A.Binop A.Map, [_; A.EArray es] ->
A.EArray
(List.map
(fun e' ->
evaluate_expr ctx
(Pos.same_pos_as (A.EApp (List.nth args 0, [e'])) e'))
es)
| A.Binop A.Filter, [_; A.EArray es] ->
A.EArray
(List.filter
(fun e' ->
match
evaluate_expr ctx
(Pos.same_pos_as (A.EApp (List.nth args 0, [e'])) e')
with
| A.ELit (A.LBool b), _ -> b
| _ ->
Errors.raise_spanned_error
(Pos.get_position (List.nth args 0))
"This predicate evaluated to something else than a boolean \
(should not happen if the term was well-typed)")
es)
| A.Binop _, ([ELit LEmptyError; _] | [_; ELit LEmptyError]) ->
A.ELit LEmptyError
| A.Unop (A.Minus KInt), [ELit (LInt i)] ->
A.ELit (LInt Runtime.(integer_of_int 0 -! i))
| A.Unop (A.Minus KRat), [ELit (LRat i)] ->
A.ELit (LRat Runtime.(decimal_of_string "0" -& i))
| A.Unop (A.Minus KMoney), [ELit (LMoney i)] ->
A.ELit (LMoney Runtime.(money_of_units_int 0 -$ i))
| A.Unop (A.Minus KDuration), [ELit (LDuration i)] ->
A.ELit (LDuration Runtime.(~-^i))
| A.Unop A.Not, [ELit (LBool b)] -> A.ELit (LBool (not b))
| A.Unop A.Length, [EArray es] ->
A.ELit (LInt (Runtime.integer_of_int (List.length es)))
| A.Unop A.GetDay, [ELit (LDate d)] ->
A.ELit (LInt Runtime.(day_of_month_of_date d))
| A.Unop A.GetMonth, [ELit (LDate d)] ->
A.ELit (LInt Runtime.(month_number_of_date d))
| A.Unop A.GetYear, [ELit (LDate d)] ->
A.ELit (LInt Runtime.(year_of_date d))
| A.Unop A.IntToRat, [ELit (LInt i)] ->
A.ELit (LRat Runtime.(decimal_of_integer i))
| A.Unop A.RoundMoney, [ELit (LMoney m)] ->
A.ELit (LMoney Runtime.(money_round m))
| A.Unop A.RoundDecimal, [ELit (LRat m)] ->
A.ELit (LRat Runtime.(decimal_round m))
| A.Unop (A.Log (entry, infos)), [e'] ->
if !Cli.trace_flag then (
match entry with
| VarDef _ ->
(* TODO: this usage of Format is broken, Formatting requires that all
is formatted in one pass, without going through intermediate
"%s" *)
Cli.log_format "%*s%a %a: %s" (!log_indent * 2) ""
Print.format_log_entry entry Print.format_uid_list infos
(match e' with
(* | Ast.EAbs _ -> Cli.with_style [ ANSITerminal.green ]
"<function>" *)
| _ ->
let expr_str =
Format.asprintf "%a"
(Print.format_expr ctx ~debug:false)
(e', Pos.no_pos)
in
let expr_str =
Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\n\\s*")
~subst:(fun _ -> " ")
expr_str
in
Cli.with_style [ANSITerminal.green] "%s" expr_str)
| PosRecordIfTrueBool -> (
let pos = Pos.get_position op in
match pos <> Pos.no_pos, e' with
| true, ELit (LBool true) ->
Cli.log_format "%*s%a%s:\n%s" (!log_indent * 2) ""
Print.format_log_entry entry
(Cli.with_style [ANSITerminal.green] "Definition applied")
(Cli.add_prefix_to_each_line (Pos.retrieve_loc_text pos) (fun _ ->
Format.asprintf "%*s" (!log_indent * 2) ""))
| _ -> ())
| BeginCall ->
Cli.log_format "%*s%a %a" (!log_indent * 2) "" Print.format_log_entry
entry Print.format_uid_list infos;
log_indent := !log_indent + 1
| EndCall ->
log_indent := !log_indent - 1;
Cli.log_format "%*s%a %a" (!log_indent * 2) "" Print.format_log_entry
entry Print.format_uid_list infos)
else ();
e'
| A.Unop _, [ELit LEmptyError] -> A.ELit LEmptyError
| _ ->
Errors.raise_multispanned_error
([Some "Operator:", Pos.get_position op]
@ List.mapi
(fun i arg ->
( Some
(Format.asprintf "Argument n°%d, value %a" (i + 1)
(Print.format_expr ctx ~debug:true)
arg),
Pos.get_position arg ))
args)
"Operator applied to the wrong arguments\n\
(should not happen if the term was well-typed)")
op
(Marked.same_mark_as (A.EApp (List.nth args 0, [e'])) e')
with
| A.ELit (A.LBool b), _ -> b
| _ ->
Errors.raise_spanned_error
(A.pos (List.nth args 0))
"This predicate evaluated to something else than a boolean \
(should not happen if the term was well-typed)")
es)
| A.Binop _, ([ELit LEmptyError; _] | [_; ELit LEmptyError]) ->
A.ELit LEmptyError
| A.Unop (A.Minus KInt), [ELit (LInt i)] ->
A.ELit (LInt Runtime.(integer_of_int 0 -! i))
| A.Unop (A.Minus KRat), [ELit (LRat i)] ->
A.ELit (LRat Runtime.(decimal_of_string "0" -& i))
| A.Unop (A.Minus KMoney), [ELit (LMoney i)] ->
A.ELit (LMoney Runtime.(money_of_units_int 0 -$ i))
| A.Unop (A.Minus KDuration), [ELit (LDuration i)] ->
A.ELit (LDuration Runtime.(~-^i))
| A.Unop A.Not, [ELit (LBool b)] -> A.ELit (LBool (not b))
| A.Unop A.Length, [EArray es] ->
A.ELit (LInt (Runtime.integer_of_int (List.length es)))
| A.Unop A.GetDay, [ELit (LDate d)] ->
A.ELit (LInt Runtime.(day_of_month_of_date d))
| A.Unop A.GetMonth, [ELit (LDate d)] ->
A.ELit (LInt Runtime.(month_number_of_date d))
| A.Unop A.GetYear, [ELit (LDate d)] -> A.ELit (LInt Runtime.(year_of_date d))
| A.Unop A.FirstDayOfMonth, [ELit (LDate d)] ->
A.ELit (LDate Runtime.(first_day_of_month d))
| A.Unop A.LastDayOfMonth, [ELit (LDate d)] ->
A.ELit (LDate Runtime.(first_day_of_month d))
| A.Unop A.IntToRat, [ELit (LInt i)] ->
A.ELit (LRat Runtime.(decimal_of_integer i))
| A.Unop A.MoneyToRat, [ELit (LMoney i)] ->
A.ELit (LRat Runtime.(decimal_of_money i))
| A.Unop A.RatToMoney, [ELit (LRat i)] ->
A.ELit (LMoney Runtime.(money_of_decimal i))
| A.Unop A.RoundMoney, [ELit (LMoney m)] ->
A.ELit (LMoney Runtime.(money_round m))
| A.Unop A.RoundDecimal, [ELit (LRat m)] ->
A.ELit (LRat Runtime.(decimal_round m))
| A.Unop (A.Log (entry, infos)), [e'] ->
if !Cli.trace_flag then (
match entry with
| VarDef _ ->
(* TODO: this usage of Format is broken, Formatting requires that all is
formatted in one pass, without going through intermediate "%s" *)
Cli.log_format "%*s%a %a: %s" (!log_indent * 2) ""
Print.format_log_entry entry Print.format_uid_list infos
(match e' with
(* | Ast.EAbs _ -> Cli.with_style [ ANSITerminal.green ]
"<function>" *)
| _ ->
let expr_str =
Format.asprintf "%a"
(Print.format_expr ctx ~debug:false)
(List.hd args)
in
let expr_str =
Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\n\\s*")
~subst:(fun _ -> " ")
expr_str
in
Cli.with_style [ANSITerminal.green] "%s" expr_str)
| PosRecordIfTrueBool -> (
match pos <> Pos.no_pos, e' with
| true, ELit (LBool true) ->
Cli.log_format "%*s%a%s:\n%s" (!log_indent * 2) ""
Print.format_log_entry entry
(Cli.with_style [ANSITerminal.green] "Definition applied")
(Cli.add_prefix_to_each_line (Pos.retrieve_loc_text pos) (fun _ ->
Format.asprintf "%*s" (!log_indent * 2) ""))
| _ -> ())
| BeginCall ->
Cli.log_format "%*s%a %a" (!log_indent * 2) "" Print.format_log_entry
entry Print.format_uid_list infos;
log_indent := !log_indent + 1
| EndCall ->
log_indent := !log_indent - 1;
Cli.log_format "%*s%a %a" (!log_indent * 2) "" Print.format_log_entry
entry Print.format_uid_list infos)
else ();
e'
| A.Unop _, [ELit LEmptyError] -> A.ELit LEmptyError
| _ ->
Errors.raise_multispanned_error
([Some "Operator:", pos]
@ List.mapi
(fun i arg ->
( Some
(Format.asprintf "Argument n°%d, value %a" (i + 1)
(Print.format_expr ctx ~debug:true)
arg),
A.pos arg ))
args)
"Operator applied to the wrong arguments\n\
(should not happen if the term was well-typed)"
>>>>>>> master
and evaluate_expr (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) :
A.expr Pos.marked =
match Pos.unmark e with
and evaluate_expr (ctx : Ast.decl_ctx) (e : 'm A.marked_expr) : 'm A.marked_expr
=
match Marked.unmark e with
| EVar _ ->
Errors.raise_spanned_error (Pos.get_position e)
Errors.raise_spanned_error (A.pos e)
"free variable found at evaluation (should not happen if term was \
well-typed"
| EApp (e1, args) -> (
let e1 = evaluate_expr ctx e1 in
let args = List.map (evaluate_expr ctx) args in
match Pos.unmark e1 with
| EAbs ((binder, _), _) ->
match Marked.unmark e1 with
| EAbs (binder, _) ->
if Bindlib.mbinder_arity binder = List.length args then
evaluate_expr ctx
(Bindlib.msubst binder (Array.of_list (List.map Pos.unmark args)))
(Bindlib.msubst binder (Array.of_list (List.map Marked.unmark args)))
else
Errors.raise_spanned_error (Pos.get_position e)
Errors.raise_spanned_error (A.pos e)
"wrong function call, expected %d arguments, got %d"
(Bindlib.mbinder_arity binder)
(List.length args)
| EOp op ->
Pos.same_pos_as
(Pos.unmark (evaluate_operator ctx (Pos.same_pos_as op e1) args))
e
| ELit LEmptyError -> Pos.same_pos_as (A.ELit LEmptyError) e
| EOp op -> Marked.same_mark_as (evaluate_operator ctx op (A.pos e) args) e
| ELit LEmptyError -> Marked.same_mark_as (A.ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error (Pos.get_position e)
Errors.raise_spanned_error (A.pos e)
"function has not been reduced to a lambda at evaluation (should not \
happen if the term was well-typed")
| EAbs _ | ELit _ | EOp _ -> e (* these are values *)
| ETuple (es, s) ->
let new_es = List.map (evaluate_expr ctx) es in
if List.exists is_empty_error new_es then
Pos.same_pos_as (A.ELit LEmptyError) e
else Pos.same_pos_as (A.ETuple (new_es, s)) e
Marked.same_mark_as (A.ELit LEmptyError) e
else Marked.same_mark_as (A.ETuple (new_es, s)) e
| ETupleAccess (e1, n, s, _) -> (
let e1 = evaluate_expr ctx e1 in
match Pos.unmark e1 with
match Marked.unmark e1 with
| ETuple (es, s') -> (
(match s, s' with
| None, None -> ()
| Some s, Some s' when s = s' -> ()
| _ ->
Errors.raise_multispanned_error
[None, Pos.get_position e; None, Pos.get_position e1]
[None, A.pos e; None, A.pos e1]
"Error during tuple access: not the same structs (should not happen \
if the term was well-typed)");
match List.nth_opt es n with
| Some e' -> e'
| None ->
Errors.raise_spanned_error (Pos.get_position e1)
Errors.raise_spanned_error (A.pos e1)
"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)
| ELit LEmptyError -> Pos.same_pos_as (A.ELit LEmptyError) e
| ELit LEmptyError -> Marked.same_mark_as (A.ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error (Pos.get_position e1)
Errors.raise_spanned_error (A.pos e1)
"The expression %a should be a tuple with %d components but is not \
(should not happen if the term was well-typed)"
(Print.format_expr ctx ~debug:true)
e n)
| EInj (e1, n, en, ts) ->
let e1' = evaluate_expr ctx e1 in
if is_empty_error e1' then Pos.same_pos_as (A.ELit LEmptyError) e
else Pos.same_pos_as (A.EInj (e1', n, en, ts)) e
if is_empty_error e1' then Marked.same_mark_as (A.ELit LEmptyError) e
else Marked.same_mark_as (A.EInj (e1', n, en, ts)) e
| EMatch (e1, es, e_name) -> (
let e1 = evaluate_expr ctx e1 in
match Pos.unmark e1 with
match Marked.unmark e1 with
| A.EInj (e1, n, e_name', _) ->
if e_name <> e_name' then
Errors.raise_multispanned_error
[None, Pos.get_position e; None, Pos.get_position e1]
[None, A.pos e; None, A.pos e1]
"Error during match: two different enums found (should not happend \
if the term was well-typed)";
let es_n =
match List.nth_opt es n with
| Some es_n -> es_n
| None ->
Errors.raise_spanned_error (Pos.get_position e)
Errors.raise_spanned_error (A.pos e)
"sum type index error (should not happend if the term was \
well-typed)"
in
let new_e = Pos.same_pos_as (A.EApp (es_n, [e1])) e in
let new_e = Marked.same_mark_as (A.EApp (es_n, [e1])) e in
evaluate_expr ctx new_e
| A.ELit A.LEmptyError -> Pos.same_pos_as (A.ELit A.LEmptyError) e
| A.ELit A.LEmptyError -> Marked.same_mark_as (A.ELit A.LEmptyError) e
| _ ->
Errors.raise_spanned_error (Pos.get_position e1)
Errors.raise_spanned_error (A.pos e1)
"Expected a term having a sum type as an argument to a match (should \
not happend if the term was well-typed")
| EDefault (exceptions, just, cons) -> (
@ -422,12 +417,12 @@ and evaluate_expr (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) :
match List.length exceptions - empty_count with
| 0 -> (
let just = evaluate_expr ctx just in
match Pos.unmark just with
| ELit LEmptyError -> Pos.same_pos_as (A.ELit LEmptyError) e
match Marked.unmark just with
| ELit LEmptyError -> Marked.same_mark_as (A.ELit LEmptyError) e
| ELit (LBool true) -> evaluate_expr ctx cons
| ELit (LBool false) -> Pos.same_pos_as (A.ELit LEmptyError) e
| ELit (LBool false) -> Marked.same_mark_as (A.ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error (Pos.get_position e)
Errors.raise_spanned_error (A.pos e)
"Default justification has not been reduced to a boolean at \
evaluation (should not happen if the term was well-typed")
| 1 -> List.find (fun sub -> not (is_empty_error sub)) exceptions
@ -435,80 +430,125 @@ and evaluate_expr (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) :
Errors.raise_multispanned_error
(List.map
(fun except ->
( Some "This consequence has a valid justification:",
Pos.get_position except ))
Some "This consequence has a valid justification:", A.pos except)
(List.filter (fun sub -> not (is_empty_error sub)) exceptions))
"There is a conflict between multiple valid consequences for assigning \
the same variable.")
| EIfThenElse (cond, et, ef) -> (
match Pos.unmark (evaluate_expr ctx cond) with
match Marked.unmark (evaluate_expr ctx cond) with
| ELit (LBool true) -> evaluate_expr ctx et
| ELit (LBool false) -> evaluate_expr ctx ef
| ELit LEmptyError -> Pos.same_pos_as (A.ELit LEmptyError) e
| ELit LEmptyError -> Marked.same_mark_as (A.ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error (Pos.get_position cond)
Errors.raise_spanned_error (A.pos cond)
"Expected a boolean literal for the result of this condition (should \
not happen if the term was well-typed)")
| EArray es ->
let new_es = List.map (evaluate_expr ctx) es in
if List.exists is_empty_error new_es then
Pos.same_pos_as (A.ELit LEmptyError) e
else Pos.same_pos_as (A.EArray new_es) e
Marked.same_mark_as (A.ELit LEmptyError) e
else Marked.same_mark_as (A.EArray new_es) e
| ErrorOnEmpty e' ->
let e' = evaluate_expr ctx e' in
if Pos.unmark e' = A.ELit LEmptyError then
Errors.raise_spanned_error (Pos.get_position e')
if Marked.unmark e' = A.ELit LEmptyError then
Errors.raise_spanned_error (A.pos e')
"This variable evaluated to an empty term (no rule that defined it \
applied in this situation)"
else e'
| EAssert e' -> (
match Pos.unmark (evaluate_expr ctx e') with
| ELit (LBool true) -> Pos.same_pos_as (Ast.ELit LUnit) e'
match Marked.unmark (evaluate_expr ctx e') with
| ELit (LBool true) -> Marked.same_mark_as (Ast.ELit LUnit) e'
| ELit (LBool false) -> (
match Pos.unmark e' with
match Marked.unmark e' with
| Ast.ErrorOnEmpty
( EApp
( (Ast.EOp (Binop op), pos_op),
( (Ast.EOp (Binop op), _),
[((ELit _, _) as e1); ((ELit _, _) as e2)] ),
_ )
| EApp
( (Ast.EOp (Ast.Unop (Ast.Log _)), _),
[
( Ast.EApp
( (Ast.EOp (Binop op), pos_op),
( (Ast.EOp (Binop op), _),
[((ELit _, _) as e1); ((ELit _, _) as e2)] ),
_ );
] )
| EApp
( (Ast.EOp (Binop op), pos_op),
[((ELit _, _) as e1); ((ELit _, _) as e2)] ) ->
Errors.raise_spanned_error (Pos.get_position e')
"Assertion failed: %a %a %a"
((Ast.EOp (Binop op), _), [((ELit _, _) as e1); ((ELit _, _) as e2)])
->
Errors.raise_spanned_error (A.pos e') "Assertion failed: %a %a %a"
(Print.format_expr ctx ~debug:false)
e1 Print.format_binop (op, pos_op)
e1 Print.format_binop op
(Print.format_expr ctx ~debug:false)
e2
| _ ->
Cli.debug_format "%a" (Print.format_expr ctx) e';
Errors.raise_spanned_error (Pos.get_position e') "Assertion failed")
| ELit LEmptyError -> Pos.same_pos_as (A.ELit LEmptyError) e
Errors.raise_spanned_error (A.pos e') "Assertion failed")
| ELit LEmptyError -> Marked.same_mark_as (A.ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error (Pos.get_position e')
Errors.raise_spanned_error (A.pos e')
"Expected a boolean literal for the result of this assertion (should \
not happen if the term was well-typed)")
(** {1 API} *)
let interpret_program (ctx : Ast.decl_ctx) (e : Ast.expr Pos.marked) :
(Uid.MarkedString.info * Ast.expr Pos.marked) list =
match Pos.unmark (evaluate_expr ctx e) with
| Ast.EAbs (_, [(Ast.TTuple (taus, Some s_in), _)]) -> (
let application_term = List.map (fun _ -> Ast.empty_thunked_term) taus in
let to_interpret =
( Ast.EApp (e, [Ast.ETuple (application_term, Some s_in), Pos.no_pos]),
Pos.no_pos )
let interpret_program :
'm.
Ast.decl_ctx ->
'm Ast.marked_expr ->
(Uid.MarkedString.info * 'm Ast.marked_expr) list =
fun (ctx : Ast.decl_ctx) (e : 'm Ast.marked_expr) :
(Uid.MarkedString.info * 'm Ast.marked_expr) list ->
match evaluate_expr ctx e with
| Ast.EAbs (_, [((Ast.TTuple (taus, Some s_in), _) as targs)]), mark_e ->
begin
(* At this point, the interpreter seeks to execute the scope but does not
have a way to retrieve input values from the command line. [taus] contain
the types of the scope arguments. For [context] arguments, we cann
provide an empty thunked term. But for [input] arguments of another type,
we cannot provide anything so we have to fail. *)
let application_term =
List.map
(fun ty ->
match Marked.unmark ty with
| A.TArrow ((A.TLit A.TUnit, _), ty_in) ->
Ast.empty_thunked_term
(A.map_mark (fun pos -> pos) (fun _ -> ty_in) mark_e)
| _ ->
Errors.raise_spanned_error (Marked.get_mark ty)
"This scope needs input arguments to be executed. But the Catala \
built-in interpreter does not have a way to retrieve input \
values from the command line, so it cannot execute this scope. \
Please create another scope thatprovide the input arguments to \
this one and execute it instead. ")
taus
in
match Pos.unmark (evaluate_expr ctx to_interpret) with
let to_interpret =
( Ast.EApp
( e,
[
( Ast.ETuple (application_term, Some s_in),
let pos =
match application_term with
| a :: _ -> A.pos a
| [] -> Pos.no_pos
in
A.map_mark (fun _ -> pos) (fun _ -> targs) mark_e );
] ),
A.map_mark
(fun pos -> pos)
(fun ty ->
match application_term, ty with
| [], t_out -> t_out
| _ :: _, (A.TArrow (_, t_out), _) -> t_out
| _ :: _, (_, bad_pos) ->
Errors.raise_spanned_error bad_pos
"@[<hv 2>(bug) Result of interpretation doesn't have the \
expected type:@ @[%a@]@]"
(Print.format_typ ctx) (fst @@ ty))
mark_e )
in
match Marked.unmark (evaluate_expr ctx to_interpret) with
| Ast.ETuple (args, Some s_out) ->
let s_out_fields =
List.map
@ -517,10 +557,11 @@ let interpret_program (ctx : Ast.decl_ctx) (e : Ast.expr Pos.marked) :
in
List.map2 (fun arg var -> var, arg) args s_out_fields
| _ ->
Errors.raise_spanned_error (Pos.get_position e)
Errors.raise_spanned_error (A.pos e)
"The interpretation of a program should always yield a struct \
corresponding to the scope variables")
corresponding to the scope variables"
end
| _ ->
Errors.raise_spanned_error (Pos.get_position e)
Errors.raise_spanned_error (A.pos e)
"The interpreter can only interpret terms starting with functions having \
thunked arguments"

6
compiler/dcalc/interpreter.mli
View File

@ -18,13 +18,13 @@
open Utils
val evaluate_expr : Ast.decl_ctx -> Ast.expr Pos.marked -> Ast.expr Pos.marked
val evaluate_expr : Ast.decl_ctx -> 'm Ast.marked_expr -> 'm Ast.marked_expr
(** Evaluates an expression according to the semantics of the default calculus. *)
val interpret_program :
Ast.decl_ctx ->
Ast.expr Pos.marked ->
(Uid.MarkedString.info * Ast.expr Pos.marked) list
'm Ast.marked_expr ->
(Uid.MarkedString.info * 'm Ast.marked_expr) list
(** Interprets 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. Returns a list of all

45
compiler/dcalc/optimizations.ml
View File

@ -18,15 +18,15 @@ open Utils
open Ast
type partial_evaluation_ctx = {
var_values : expr Pos.marked Ast.VarMap.t;
var_values : typed marked_expr Ast.VarMap.t;
decl_ctx : decl_ctx;
}
let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : expr Pos.marked)
: expr Pos.marked Bindlib.box =
let pos = Pos.get_position e in
let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : 'm marked_expr) :
'm marked_expr Bindlib.box =
let pos = Marked.get_mark e in
let rec_helper = partial_evaluation ctx in
match Pos.unmark e with
match Marked.unmark e with
| EApp
( (( EOp (Unop Not), _
| EApp ((EOp (Unop (Log _)), _), [(EOp (Unop Not), _)]), _ ) as op),
@ -64,7 +64,7 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : expr Pos.marked)
ELit (LBool false), pos
| _ -> EApp (op, [e1; e2]), pos))
(rec_helper e1) (rec_helper e2)
| EVar (x, _) -> Bindlib.box_apply (fun x -> x, pos) (Bindlib.box_var x)
| EVar x -> Bindlib.box_apply (fun x -> x, pos) (Bindlib.box_var x)
| ETuple (args, s_name) ->
Bindlib.box_apply
(fun args -> ETuple (args, s_name), pos)
@ -93,18 +93,16 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : expr Pos.marked)
(fun args -> EArray args, pos)
(List.map rec_helper args |> Bindlib.box_list)
| ELit l -> Bindlib.box (ELit l, pos)
| EAbs ((binder, binder_pos), typs) ->
| EAbs (binder, typs) ->
let vars, body = Bindlib.unmbind binder in
let new_body = rec_helper body in
let new_binder = Bindlib.bind_mvar vars new_body in
Bindlib.box_apply
(fun binder -> EAbs ((binder, binder_pos), typs), pos)
new_binder
Bindlib.box_apply (fun binder -> EAbs (binder, typs), pos) new_binder
| EApp (f, args) ->
Bindlib.box_apply2
(fun f args ->
match Pos.unmark f with
| EAbs ((binder, _pos_binder), _ts) ->
match Marked.unmark f with
| EAbs (binder, _ts) ->
(* beta reduction *)
Bindlib.msubst binder (List.map fst args |> Array.of_list)
| _ -> EApp (f, args), pos)
@ -119,7 +117,7 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : expr Pos.marked)
match
( List.filter
(fun except ->
match Pos.unmark except with
match Marked.unmark except with
| ELit LEmptyError -> false
| _ -> true)
exceptions
@ -166,7 +164,7 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : expr Pos.marked)
| EIfThenElse (e1, e2, e3) ->
Bindlib.box_apply3
(fun e1 e2 e3 ->
match Pos.unmark e1, Pos.unmark e2, Pos.unmark e3 with
match Marked.unmark e1, Marked.unmark e2, Marked.unmark e3 with
| ELit (LBool true), _, _
| EApp ((EOp (Unop (Log _)), _), [(ELit (LBool true), _)]), _, _ ->
e2
@ -185,14 +183,14 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : expr Pos.marked)
| ErrorOnEmpty e1 ->
Bindlib.box_apply (fun e1 -> ErrorOnEmpty e1, pos) (rec_helper e1)
let optimize_expr (decl_ctx : decl_ctx) (e : expr Pos.marked) =
let optimize_expr (decl_ctx : decl_ctx) (e : 'm marked_expr) =
partial_evaluation { var_values = VarMap.empty; decl_ctx } e
let rec scope_lets_map
(t : 'a -> expr Pos.marked -> expr Pos.marked Bindlib.box)
(t : 'a -> 'm marked_expr -> 'm marked_expr Bindlib.box)
(ctx : 'a)
(scope_body_expr : expr scope_body_expr) : expr scope_body_expr Bindlib.box
=
(scope_body_expr : ('m expr, 'm) scope_body_expr) :
('m expr, 'm) scope_body_expr Bindlib.box =
match scope_body_expr with
| Result e -> Bindlib.box_apply (fun e' -> Result e') (t ctx e)
| ScopeLet scope_let ->
@ -211,9 +209,9 @@ let rec scope_lets_map
new_scope_let_expr new_next
let rec scopes_map
(t : 'a -> expr Pos.marked -> expr Pos.marked Bindlib.box)
(t : 'a -> 'm marked_expr -> 'm marked_expr Bindlib.box)
(ctx : 'a)
(scopes : expr scopes) : expr scopes Bindlib.box =
(scopes : ('m expr, 'm) scopes) : ('m expr, 'm) scopes Bindlib.box =
match scopes with
| Nil -> Bindlib.box Nil
| ScopeDef scope_def ->
@ -242,15 +240,16 @@ let rec scopes_map
new_scope_body_expr new_scope_next
let program_map
(t : 'a -> expr Pos.marked -> expr Pos.marked Bindlib.box)
(t : 'a -> 'm marked_expr -> 'm marked_expr Bindlib.box)
(ctx : 'a)
(p : program) : program Bindlib.box =
(p : 'm program) : 'm program Bindlib.box =
Bindlib.box_apply
(fun new_scopes -> { p with scopes = new_scopes })
(scopes_map t ctx p.scopes)
let optimize_program (p : program) : program =
let optimize_program (p : 'm program) : untyped program =
Bindlib.unbox
(program_map partial_evaluation
{ var_values = VarMap.empty; decl_ctx = p.decl_ctx }
p)
|> untype_program

5
compiler/dcalc/optimizations.mli
View File

@ -17,8 +17,7 @@
(** Optimization passes for default calculus programs and expressions *)
open Utils
open Ast
val optimize_expr : decl_ctx -> expr Pos.marked -> expr Pos.marked Bindlib.box
val optimize_program : program -> program
val optimize_expr : decl_ctx -> 'm marked_expr -> 'm marked_expr Bindlib.box
val optimize_program : 'm program -> untyped program

114
compiler/dcalc/print.ml
View File

@ -16,21 +16,10 @@
open Utils
open Ast
open String_common
let typ_needs_parens (e : typ Pos.marked) : bool =
match Pos.unmark e with TArrow _ | TArray _ -> true | _ -> false
let is_uppercase (x : CamomileLibraryDefault.Camomile.UChar.t) : bool =
try
match CamomileLibraryDefault.Camomile.UCharInfo.general_category x with
| `Ll -> false
| `Lu -> true
| _ -> false
with _ -> true
let begins_with_uppercase (s : string) : bool =
let first_letter = CamomileLibraryDefault.Camomile.UTF8.get s 0 in
is_uppercase first_letter
let typ_needs_parens (e : typ) : bool =
match e with TArrow _ | TArray _ -> true | _ -> false
let format_uid_list
(fmt : Format.formatter)
@ -41,7 +30,7 @@ let format_uid_list
(fun fmt info ->
Format.fprintf fmt "%a"
(Utils.Cli.format_with_style
(if begins_with_uppercase (Pos.unmark info) then
(if begins_with_uppercase (Marked.unmark info) then
[ANSITerminal.red]
else []))
(Format.asprintf "%a" Utils.Uid.MarkedString.format_info info)))
@ -79,23 +68,21 @@ let format_enum_constructor (fmt : Format.formatter) (c : EnumConstructor.t) :
(Utils.Cli.format_with_style [ANSITerminal.magenta])
(Format.asprintf "%a" EnumConstructor.format_t c)
let rec format_typ
(ctx : Ast.decl_ctx)
(fmt : Format.formatter)
(typ : typ Pos.marked) : unit =
let rec format_typ (ctx : Ast.decl_ctx) (fmt : Format.formatter) (typ : typ) :
unit =
let format_typ = format_typ ctx in
let format_typ_with_parens (fmt : Format.formatter) (t : typ Pos.marked) =
let format_typ_with_parens (fmt : Format.formatter) (t : typ) =
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
match typ with
| TLit l -> Format.fprintf fmt "%a" format_tlit l
| TTuple (ts, None) ->
Format.fprintf fmt "@[<hov 2>(%a)@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ %a@ " format_operator "*")
(fun fmt t -> Format.fprintf fmt "%a" format_typ t))
ts
(List.map Marked.unmark ts)
| TTuple (_args, Some s) ->
Format.fprintf fmt "@[<hov 2>%a%a%a%a@]" Ast.StructName.format_t s
format_punctuation "{"
@ -106,7 +93,9 @@ let rec format_typ
Format.fprintf fmt "%a%a%a%a@ %a" format_punctuation "\""
StructFieldName.format_t field format_punctuation "\""
format_punctuation ":" format_typ typ))
(StructMap.find s ctx.ctx_structs)
(List.map
(fun (c, t) -> c, Marked.unmark t)
(StructMap.find s ctx.ctx_structs))
format_punctuation "}"
| TEnum (_, e) ->
Format.fprintf fmt "@[<hov 2>%a%a%a%a@]" Ast.EnumName.format_t e
@ -117,19 +106,21 @@ let rec format_typ
(fun fmt (case, typ) ->
Format.fprintf fmt "%a%a@ %a" format_enum_constructor case
format_punctuation ":" format_typ typ))
(EnumMap.find e ctx.ctx_enums)
(List.map
(fun (c, t) -> c, Marked.unmark t)
(EnumMap.find e ctx.ctx_enums))
format_punctuation "]"
| TArrow (t1, t2) ->
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" format_typ_with_parens t1
format_operator "→" format_typ t2
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" format_typ_with_parens
(Marked.unmark t1) format_operator "→" format_typ (Marked.unmark t2)
| TArray t1 ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_base_type "array" format_typ
t1
(Marked.unmark t1)
| TAny -> format_base_type fmt "any"
(* (EmileRolley) NOTE: seems to be factorizable with Lcalc.Print.format_lit. *)
let format_lit (fmt : Format.formatter) (l : lit Pos.marked) : unit =
match Pos.unmark l with
let format_lit (fmt : Format.formatter) (l : lit) : unit =
match l with
| LBool b -> format_lit_style fmt (string_of_bool b)
| LInt i -> format_lit_style fmt (Runtime.integer_to_string i)
| LEmptyError -> format_lit_style fmt "∅ "
@ -158,9 +149,9 @@ let format_op_kind (fmt : Format.formatter) (k : op_kind) =
| KDate -> "@"
| KDuration -> "^")
let format_binop (fmt : Format.formatter) (op : binop Pos.marked) : unit =
let format_binop (fmt : Format.formatter) (op : binop) : unit =
format_operator fmt
(match Pos.unmark op with
(match op with
| Add k -> Format.asprintf "+%a" format_op_kind k
| Sub k -> Format.asprintf "-%a" format_op_kind k
| Mult k -> Format.asprintf "*%a" format_op_kind k
@ -178,8 +169,8 @@ let format_binop (fmt : Format.formatter) (op : binop Pos.marked) : unit =
| Map -> "map"
| Filter -> "filter")
let format_ternop (fmt : Format.formatter) (op : ternop Pos.marked) : unit =
match Pos.unmark op with Fold -> format_keyword fmt "fold"
let format_ternop (fmt : Format.formatter) (op : ternop) : unit =
match op with Fold -> format_keyword fmt "fold"
let format_log_entry (fmt : Format.formatter) (entry : log_entry) : unit =
Format.fprintf fmt "@<2>%s"
@ -189,9 +180,9 @@ let format_log_entry (fmt : Format.formatter) (entry : log_entry) : unit =
| EndCall -> Utils.Cli.with_style [ANSITerminal.yellow] "← "
| PosRecordIfTrueBool -> Utils.Cli.with_style [ANSITerminal.green] "☛ ")
let format_unop (fmt : Format.formatter) (op : unop Pos.marked) : unit =
let format_unop (fmt : Format.formatter) (op : unop) : unit =
Format.fprintf fmt "%s"
(match Pos.unmark op with
(match op with
| Minus _ -> "-"
| Not -> "~"
| Log (entry, infos) ->
@ -202,32 +193,36 @@ let format_unop (fmt : Format.formatter) (op : unop Pos.marked) : unit =
infos
| Length -> "length"
| IntToRat -> "int_to_rat"
| MoneyToRat -> "money_to_rat"
| RatToMoney -> "rat_to_money"
| GetDay -> "get_day"
| GetMonth -> "get_month"
| GetYear -> "get_year"
| FirstDayOfMonth -> "first_day_of_month"
| LastDayOfMonth -> "last_day_of_month"
| RoundMoney -> "round_money"
| RoundDecimal -> "round_decimal")
let needs_parens (e : expr Pos.marked) : bool =
match Pos.unmark e with EAbs _ | ETuple (_, Some _) -> true | _ -> false
let needs_parens (e : 'm marked_expr) : bool =
match Marked.unmark e with EAbs _ | ETuple (_, Some _) -> true | _ -> false
let format_var (fmt : Format.formatter) (v : Var.t) : unit =
let format_var (fmt : Format.formatter) (v : 'm Ast.var) : unit =
Format.fprintf fmt "%s_%d" (Bindlib.name_of v) (Bindlib.uid_of v)
let rec format_expr
?(debug : bool = false)
(ctx : Ast.decl_ctx)
(fmt : Format.formatter)
(e : expr Pos.marked) : unit =
(e : 'm marked_expr) : unit =
let format_expr = format_expr ~debug ctx in
let format_with_parens (fmt : Format.formatter) (e : expr Pos.marked) =
let format_with_parens (fmt : Format.formatter) (e : 'm marked_expr) =
if needs_parens e then
Format.fprintf fmt "%a%a%a" format_punctuation "(" format_expr e
format_punctuation ")"
else Format.fprintf fmt "%a" format_expr e
in
match Pos.unmark e with
| EVar v -> Format.fprintf fmt "%a" format_var (Pos.unmark v)
match Marked.unmark e with
| EVar v -> Format.fprintf fmt "%a" format_var v
| ETuple (es, None) ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" format_punctuation "("
(Format.pp_print_list
@ -274,10 +269,12 @@ let rec format_expr
Format.fprintf fmt "@[<hov 2>%a %a%a@ %a@]" format_punctuation "|"
format_enum_constructor c format_punctuation ":" format_expr e))
(List.combine es (List.map fst (Ast.EnumMap.find e_name ctx.ctx_enums)))
| ELit l -> format_lit fmt (Pos.same_pos_as l e)
| EApp ((EAbs ((binder, _), taus), _), args) ->
| ELit l -> format_lit fmt l
| 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 =
List.map2 (fun x tau -> x, Marked.unmark 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
@ -288,9 +285,11 @@ let rec format_expr
(format_typ ctx) tau format_punctuation "=" format_expr arg
format_keyword "in"))
xs_tau_arg format_expr body
| EAbs ((binder, _), taus) ->
| EAbs (binder, taus) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> x, tau) (Array.to_list xs) taus in
let xs_tau =
List.map2 (fun x tau -> x, Marked.unmark tau) (Array.to_list xs) taus
in
Format.fprintf fmt "@[<hov 2>%a @[<hov 2>%a@] %a@ %a@]" format_punctuation
"λ"
(Format.pp_print_list
@ -300,16 +299,16 @@ let rec format_expr
format_punctuation ":" (format_typ ctx) tau format_punctuation ")"))
xs_tau format_punctuation "→" format_expr body
| EApp ((EOp (Binop ((Ast.Map | Ast.Filter) as op)), _), [arg1; arg2]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_binop (op, Pos.no_pos)
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_binop op
format_with_parens arg1 format_with_parens arg2
| EApp ((EOp (Binop op), _), [arg1; arg2]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1
format_binop (op, Pos.no_pos) format_with_parens arg2
format_binop op format_with_parens arg2
| EApp ((EOp (Unop (Log _)), _), [arg1]) when not debug ->
format_expr fmt arg1
| EApp ((EOp (Unop op), _), [arg1]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_unop (op, Pos.no_pos)
format_with_parens arg1
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_unop op format_with_parens
arg1
| EApp (f, args) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_expr f
(Format.pp_print_list
@ -320,9 +319,9 @@ let rec format_expr
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@]" format_keyword "if"
format_expr e1 format_keyword "then" format_expr e2 format_keyword "else"
format_expr e3
| EOp (Ternop op) -> Format.fprintf fmt "%a" format_ternop (op, Pos.no_pos)
| EOp (Binop op) -> Format.fprintf fmt "%a" format_binop (op, Pos.no_pos)
| EOp (Unop op) -> Format.fprintf fmt "%a" format_unop (op, Pos.no_pos)
| EOp (Ternop op) -> Format.fprintf fmt "%a" format_ternop op
| EOp (Binop op) -> Format.fprintf fmt "%a" format_binop op
| EOp (Unop op) -> Format.fprintf fmt "%a" format_unop op
| EDefault (exceptions, just, cons) ->
if List.length exceptions = 0 then
Format.fprintf fmt "@[<hov 2>%a%a@ %a@ %a%a@]" format_punctuation "⟨"
@ -348,10 +347,13 @@ let format_scope
?(debug : bool = false)
(ctx : decl_ctx)
(fmt : Format.formatter)
((n, s) : Ast.ScopeName.t * Ast.expr scope_body) =
((n, s) : Ast.ScopeName.t * ('m Ast.expr, 'm) scope_body) =
Format.fprintf fmt "@[<hov 2>%a %a =@ %a@]" format_keyword "let"
Ast.ScopeName.format_t n (format_expr ctx ~debug)
(Bindlib.unbox
(Ast.build_whole_scope_expr ~make_abs:Ast.make_abs
~make_let_in:Ast.make_let_in ~box_expr:Ast.box_expr ctx s
(Pos.get_position (Ast.ScopeName.get_info n))))
(Ast.map_mark
(fun _ -> Marked.get_mark (Ast.ScopeName.get_info n))
(fun ty -> ty)
(Ast.get_scope_body_mark s))))

21
compiler/dcalc/print.mli
View File

@ -18,11 +18,6 @@
open Utils
(** {1 Helpers} *)
val is_uppercase : CamomileLibraryDefault.Camomile.UChar.t -> bool
val begins_with_uppercase : string -> bool
(** {1 Common syntax highlighting helpers}*)
val format_base_type : Format.formatter -> string -> unit
@ -36,25 +31,25 @@ val format_lit_style : Format.formatter -> string -> unit
val format_uid_list : Format.formatter -> Uid.MarkedString.info list -> unit
val format_enum_constructor : Format.formatter -> Ast.EnumConstructor.t -> unit
val format_tlit : Format.formatter -> Ast.typ_lit -> unit
val format_typ : Ast.decl_ctx -> Format.formatter -> Ast.typ Pos.marked -> unit
val format_lit : Format.formatter -> Ast.lit Pos.marked -> unit
val format_typ : Ast.decl_ctx -> Format.formatter -> Ast.typ -> unit
val format_lit : Format.formatter -> Ast.lit -> unit
val format_op_kind : Format.formatter -> Ast.op_kind -> unit
val format_binop : Format.formatter -> Ast.binop Pos.marked -> unit
val format_ternop : Format.formatter -> Ast.ternop Pos.marked -> unit
val format_binop : Format.formatter -> Ast.binop -> unit
val format_ternop : Format.formatter -> Ast.ternop -> unit
val format_log_entry : Format.formatter -> Ast.log_entry -> unit
val format_unop : Format.formatter -> Ast.unop Pos.marked -> unit
val format_var : Format.formatter -> Ast.Var.t -> unit
val format_unop : Format.formatter -> Ast.unop -> unit
val format_var : Format.formatter -> 'm Ast.var -> unit
val format_expr :
?debug:bool (** [true] for debug printing *) ->
Ast.decl_ctx ->
Format.formatter ->
Ast.expr Pos.marked ->
'm Ast.marked_expr ->
unit
val format_scope :
?debug:bool (** [true] for debug printing *) ->
Ast.decl_ctx ->
Format.formatter ->
Ast.ScopeName.t * Ast.expr Ast.scope_body ->
Ast.ScopeName.t * ('m Ast.expr, 'm) Ast.scope_body ->
unit

967
compiler/dcalc/typing.ml
View File

File diff suppressed because it is too large Load Diff

16
compiler/dcalc/typing.mli
View File

@ -17,8 +17,18 @@
(** Typing for the default calculus. Because of the error terms, we perform type
inference using the classical W algorithm with union-find unification. *)
val infer_type :
Ast.decl_ctx -> Ast.expr Utils.Pos.marked -> Ast.typ Utils.Pos.marked
val infer_types :
Ast.decl_ctx ->
Ast.untyped Ast.marked_expr ->
Ast.typed Ast.marked_expr Bindlib.box
(** Infers types everywhere on the given expression, and adds (or replaces) type
annotations on each node *)
val infer_type : Ast.decl_ctx -> 'm Ast.marked_expr -> Ast.typ Utils.Marked.pos
(** Gets the outer type of the given expression, using either the existing
annotations or inference *)
val check_type :
Ast.decl_ctx -> Ast.expr Utils.Pos.marked -> Ast.typ Utils.Pos.marked -> unit
Ast.decl_ctx -> 'm Ast.marked_expr -> Ast.typ Utils.Marked.pos -> unit
val infer_types_program : Ast.untyped Ast.program -> Ast.typed Ast.program

159
compiler/desugared/ast.ml
View File

@ -69,10 +69,10 @@ module ScopeDef = struct
let get_position x =
match x with
| Var (x, None) -> Pos.get_position (ScopeVar.get_info x)
| Var (_, Some sx) -> Pos.get_position (StateName.get_info sx)
| Var (x, None) -> Marked.get_mark (ScopeVar.get_info x)
| Var (_, Some sx) -> Marked.get_mark (StateName.get_info sx)
| SubScopeVar (x, _) ->
Pos.get_position (Scopelang.Ast.SubScopeName.get_info x)
Marked.get_mark (Scopelang.Ast.SubScopeName.get_info x)
let format_t fmt x =
match x with
@ -97,22 +97,22 @@ module ScopeDefSet : Set.S with type elt = ScopeDef.t = Set.Make (ScopeDef)
(** {1 AST} *)
type location =
| ScopeVar of ScopeVar.t Pos.marked * StateName.t option
| ScopeVar of ScopeVar.t Marked.pos * StateName.t option
| SubScopeVar of
Scopelang.Ast.ScopeName.t
* Scopelang.Ast.SubScopeName.t Pos.marked
* ScopeVar.t Pos.marked
* Scopelang.Ast.SubScopeName.t Marked.pos
* ScopeVar.t Marked.pos
module LocationSet : Set.S with type elt = location Pos.marked =
module LocationSet : Set.S with type elt = location Marked.pos =
Set.Make (struct
type t = location Pos.marked
type t = location Marked.pos
let compare x y =
match Pos.unmark x, Pos.unmark y with
match Marked.unmark x, Marked.unmark y with
| ScopeVar (vx, None), ScopeVar (vy, None)
| ScopeVar (vx, Some _), ScopeVar (vy, None)
| ScopeVar (vx, None), ScopeVar (vy, Some _) ->
ScopeVar.compare (Pos.unmark vx) (Pos.unmark vy)
ScopeVar.compare (Marked.unmark vx) (Marked.unmark vy)
| ScopeVar ((x, _), Some sx), ScopeVar ((y, _), Some sy) ->
let cmp = ScopeVar.compare x y in
if cmp = 0 then StateName.compare sx sy else cmp
@ -124,36 +124,32 @@ Set.Make (struct
| SubScopeVar _, ScopeVar _ -> 1
end)
type marked_expr = expr Marked.pos
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib}
library, based on higher-order abstract syntax*)
type expr =
and expr =
| ELocation of location
| EVar of expr Bindlib.var Pos.marked
| EVar of expr Bindlib.var
| EStruct of
Scopelang.Ast.StructName.t
* expr Pos.marked Scopelang.Ast.StructFieldMap.t
Scopelang.Ast.StructName.t * marked_expr Scopelang.Ast.StructFieldMap.t
| EStructAccess of
expr Pos.marked
* Scopelang.Ast.StructFieldName.t
* Scopelang.Ast.StructName.t
marked_expr * Scopelang.Ast.StructFieldName.t * Scopelang.Ast.StructName.t
| EEnumInj of
expr Pos.marked
* Scopelang.Ast.EnumConstructor.t
* Scopelang.Ast.EnumName.t
marked_expr * Scopelang.Ast.EnumConstructor.t * Scopelang.Ast.EnumName.t
| EMatch of
expr Pos.marked
marked_expr
* Scopelang.Ast.EnumName.t
* expr Pos.marked Scopelang.Ast.EnumConstructorMap.t
* marked_expr Scopelang.Ast.EnumConstructorMap.t
| ELit of Dcalc.Ast.lit
| EAbs of
(expr, expr Pos.marked) Bindlib.mbinder Pos.marked
* Scopelang.Ast.typ Pos.marked list
| EApp of expr Pos.marked * expr Pos.marked list
(expr, marked_expr) Bindlib.mbinder * Scopelang.Ast.typ Marked.pos list
| EApp of marked_expr * marked_expr list
| EOp of Dcalc.Ast.operator
| EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
| EArray of expr Pos.marked list
| ErrorOnEmpty of expr Pos.marked
| EDefault of marked_expr list * marked_expr * marked_expr
| EIfThenElse of marked_expr * marked_expr * marked_expr
| EArray of marked_expr list
| ErrorOnEmpty of marked_expr
module Expr = struct
type t = expr
@ -172,13 +168,12 @@ module Expr = struct
in
match e1, e2 with
| ELocation _, ELocation _ -> 0
| EVar (v1, _), EVar (v2, _) -> Bindlib.compare_vars v1 v2
| EVar v1, EVar v2 -> Bindlib.compare_vars v1 v2
| EStruct (name1, field_map1), EStruct (name2, field_map2) -> (
match Scopelang.Ast.StructName.compare name1 name2 with
| 0 ->
Scopelang.Ast.StructFieldMap.compare
(Pos.compare_marked compare)
field_map1 field_map2
Scopelang.Ast.StructFieldMap.compare (Marked.compare compare) field_map1
field_map2
| n -> n)
| ( EStructAccess ((e1, _), field_name1, struct_name1),
EStructAccess ((e2, _), field_name2, struct_name2) ) -> (
@ -200,15 +195,14 @@ module Expr = struct
| 0 -> (
match Scopelang.Ast.EnumName.compare name1 name2 with
| 0 ->
Scopelang.Ast.EnumConstructorMap.compare
(Pos.compare_marked compare)
Scopelang.Ast.EnumConstructorMap.compare (Marked.compare compare)
emap1 emap2
| n -> n)
| n -> n)
| ELit l1, ELit l2 -> Stdlib.compare l1 l2
| EAbs ((binder1, _), typs1), EAbs ((binder2, _), typs2) -> (
| EAbs (binder1, typs1), EAbs (binder2, typs2) -> (
match
list_compare (Pos.compare_marked Scopelang.Ast.Typ.compare) typs1 typs2
list_compare (Marked.compare Scopelang.Ast.Typ.compare) typs1 typs2
with
| 0 ->
let _, (e1, _), (e2, _) = Bindlib.unmbind2 binder1 binder2 in
@ -224,7 +218,7 @@ module Expr = struct
match compare just1 just2 with
| 0 -> (
match compare cons1 cons2 with
| 0 -> list_compare (Pos.compare_marked compare) exs1 exs2
| 0 -> list_compare (Marked.compare compare) exs1 exs2
| n -> n)
| n -> n)
| ( EIfThenElse ((i1, _), (t1, _), (e1, _)),
@ -268,22 +262,28 @@ module ExprMap = Map.Make (Expr)
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 make (s : string) : t =
Bindlib.new_var (fun (x : expr Bindlib.var) : expr -> EVar x) s
let compare x y = Bindlib.compare_vars x y
end
type vars = expr Bindlib.mvar
type exception_situation =
| BaseCase
| ExceptionToLabel of LabelName.t Marked.pos
| ExceptionToRule of RuleName.t Marked.pos
type label_situation = ExplicitlyLabeled of LabelName.t Marked.pos | Unlabeled
type rule = {
rule_id : RuleName.t;
rule_just : expr Pos.marked Bindlib.box;
rule_cons : expr Pos.marked Bindlib.box;
rule_parameter : (Var.t * Scopelang.Ast.typ Pos.marked) option;
rule_exception_to_rules : RuleSet.t Pos.marked;
rule_just : expr Marked.pos Bindlib.box;
rule_cons : expr Marked.pos Bindlib.box;
rule_parameter : (Var.t * Scopelang.Ast.typ Marked.pos) option;
rule_exception : exception_situation;
rule_label : label_situation;
}
module Rule = struct
@ -323,46 +323,47 @@ end
let empty_rule
(pos : Pos.t)
(have_parameter : Scopelang.Ast.typ Pos.marked option) : rule =
(have_parameter : Scopelang.Ast.typ Marked.pos option) : rule =
{
rule_just = Bindlib.box (ELit (Dcalc.Ast.LBool false), pos);
rule_cons = Bindlib.box (ELit Dcalc.Ast.LEmptyError, pos);
rule_parameter =
(match have_parameter with
| Some typ -> Some (Var.make ("dummy", pos), typ)
| Some typ -> Some (Var.make "dummy", typ)
| None -> None);
rule_exception_to_rules = RuleSet.empty, pos;
rule_exception = BaseCase;
rule_id = RuleName.fresh ("empty", pos);
rule_label = Unlabeled;
}
let always_false_rule
(pos : Pos.t)
(have_parameter : Scopelang.Ast.typ Pos.marked option) : rule =
(have_parameter : Scopelang.Ast.typ Marked.pos option) : rule =
{
rule_just = Bindlib.box (ELit (Dcalc.Ast.LBool true), pos);
rule_cons = Bindlib.box (ELit (Dcalc.Ast.LBool false), pos);
rule_parameter =
(match have_parameter with
| Some typ -> Some (Var.make ("dummy", pos), typ)
| Some typ -> Some (Var.make "dummy", typ)
| None -> None);
rule_exception_to_rules = RuleSet.empty, pos;
rule_exception = BaseCase;
rule_id = RuleName.fresh ("always_false", pos);
rule_label = Unlabeled;
}
type assertion = expr Pos.marked Bindlib.box
type assertion = expr Marked.pos 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
| FixedBy of reference_typ Marked.pos
| VariesWith of unit * variation_typ Marked.pos option
type scope_def = {
scope_def_rules : rule RuleMap.t;
scope_def_typ : Scopelang.Ast.typ Pos.marked;
scope_def_typ : Scopelang.Ast.typ Marked.pos;
scope_def_is_condition : bool;
scope_def_io : Scopelang.Ast.io;
scope_def_label_groups : RuleSet.t LabelMap.t;
}
type var_or_states = WholeVar | States of StateName.t list
@ -382,11 +383,11 @@ type program = {
program_structs : Scopelang.Ast.struct_ctx;
}
let rec locations_used (e : expr Pos.marked) : LocationSet.t =
match Pos.unmark e with
| ELocation l -> LocationSet.singleton (l, Pos.get_position e)
let rec locations_used (e : expr Marked.pos) : LocationSet.t =
match Marked.unmark e with
| ELocation l -> LocationSet.singleton (l, Marked.get_mark e)
| EVar _ | ELit _ | EOp _ -> LocationSet.empty
| EAbs ((binder, _), _) ->
| EAbs (binder, _) ->
let _, body = Bindlib.unmbind binder in
locations_used body
| EStruct (_, es) ->
@ -424,9 +425,9 @@ let free_variables (def : rule RuleMap.t) : Pos.t ScopeDefMap.t =
(fun (loc, loc_pos) acc ->
ScopeDefMap.add
(match loc with
| ScopeVar (v, st) -> ScopeDef.Var (Pos.unmark v, st)
| ScopeVar (v, st) -> ScopeDef.Var (Marked.unmark v, st)
| SubScopeVar (_, sub_index, sub_var) ->
ScopeDef.SubScopeVar (Pos.unmark sub_index, Pos.unmark sub_var))
ScopeDef.SubScopeVar (Marked.unmark sub_index, Marked.unmark sub_var))
loc_pos acc)
locs acc
in
@ -440,36 +441,30 @@ let free_variables (def : rule RuleMap.t) : Pos.t ScopeDefMap.t =
add_locs acc locs)
def ScopeDefMap.empty
let make_var ((x, pos) : Var.t Pos.marked) : expr Pos.marked Bindlib.box =
let make_var ((x, pos) : Var.t Marked.pos) : expr Marked.pos 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 : Scopelang.Ast.typ Pos.marked list)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply
(fun b -> EAbs ((b, pos_binder), taus), pos)
(Bindlib.bind_mvar xs e)
(e : expr Marked.pos Bindlib.box)
(taus : Scopelang.Ast.typ Marked.pos list)
(pos : Pos.t) : expr Marked.pos Bindlib.box =
Bindlib.box_apply (fun b -> EAbs (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 =
(e : expr Marked.pos Bindlib.box)
(u : expr Marked.pos Bindlib.box list)
(pos : Pos.t) : expr Marked.pos 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 : Scopelang.Ast.typ Pos.marked)
(e1 : expr Pos.marked Bindlib.box)
(e2 : expr Pos.marked Bindlib.box) : expr Pos.marked Bindlib.box =
(tau : Scopelang.Ast.typ Marked.pos)
(e1 : expr Marked.pos Bindlib.box)
(e2 : expr Marked.pos Bindlib.box) : expr Marked.pos 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)))
(fun e u -> EApp (e, u), Marked.get_mark (Bindlib.unbox e2))
(make_abs (Array.of_list [x]) e2 [tau] (Marked.get_mark (Bindlib.unbox e2)))
(Bindlib.box_list [e1])
module VarMap = Map.Make (Var)

98
compiler/desugared/ast.mli
View File

@ -52,44 +52,40 @@ module ScopeDefSet : Set.S with type elt = ScopeDef.t
(**{2 Expressions}*)
type location =
| ScopeVar of ScopeVar.t Pos.marked * StateName.t option
| ScopeVar of ScopeVar.t Marked.pos * StateName.t option
| SubScopeVar of
Scopelang.Ast.ScopeName.t
* Scopelang.Ast.SubScopeName.t Pos.marked
* ScopeVar.t Pos.marked
* Scopelang.Ast.SubScopeName.t Marked.pos
* ScopeVar.t Marked.pos
module LocationSet : Set.S with type elt = location Pos.marked
module LocationSet : Set.S with type elt = location Marked.pos
type marked_expr = expr Marked.pos
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib}
library, based on higher-order abstract syntax*)
type expr =
and expr =
| ELocation of location
| EVar of expr Bindlib.var Pos.marked
| EVar of expr Bindlib.var
| EStruct of
Scopelang.Ast.StructName.t
* expr Pos.marked Scopelang.Ast.StructFieldMap.t
Scopelang.Ast.StructName.t * marked_expr Scopelang.Ast.StructFieldMap.t
| EStructAccess of
expr Pos.marked
* Scopelang.Ast.StructFieldName.t
* Scopelang.Ast.StructName.t
marked_expr * Scopelang.Ast.StructFieldName.t * Scopelang.Ast.StructName.t
| EEnumInj of
expr Pos.marked
* Scopelang.Ast.EnumConstructor.t
* Scopelang.Ast.EnumName.t
marked_expr * Scopelang.Ast.EnumConstructor.t * Scopelang.Ast.EnumName.t
| EMatch of
expr Pos.marked
marked_expr
* Scopelang.Ast.EnumName.t
* expr Pos.marked Scopelang.Ast.EnumConstructorMap.t
* marked_expr Scopelang.Ast.EnumConstructorMap.t
| ELit of Dcalc.Ast.lit
| EAbs of
(expr, expr Pos.marked) Bindlib.mbinder Pos.marked
* Scopelang.Ast.typ Pos.marked list
| EApp of expr Pos.marked * expr Pos.marked list
(expr, marked_expr) Bindlib.mbinder * Scopelang.Ast.typ Marked.pos list
| EApp of marked_expr * marked_expr list
| EOp of Dcalc.Ast.operator
| EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
| EArray of expr Pos.marked list
| ErrorOnEmpty of expr Pos.marked
| EDefault of marked_expr list * marked_expr * marked_expr
| EIfThenElse of marked_expr * marked_expr * marked_expr
| EArray of marked_expr list
| ErrorOnEmpty of marked_expr
module ExprMap : Map.S with type key = expr
@ -98,7 +94,7 @@ module ExprMap : Map.S with type key = expr
module Var : sig
type t = expr Bindlib.var
val make : string Pos.marked -> t
val make : string -> t
val compare : t -> t -> int
end
@ -106,58 +102,64 @@ module VarMap : Map.S with type key = Var.t
type vars = expr Bindlib.mvar
val make_var : Var.t Pos.marked -> expr Pos.marked Bindlib.box
val make_var : Var.t Marked.pos -> expr Marked.pos Bindlib.box
val make_abs :
vars ->
expr Pos.marked Bindlib.box ->
expr Marked.pos Bindlib.box ->
Scopelang.Ast.typ Marked.pos list ->
Pos.t ->
Scopelang.Ast.typ Pos.marked list ->
Pos.t ->
expr Pos.marked Bindlib.box
expr Marked.pos Bindlib.box
val make_app :
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box list ->
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box list ->
Pos.t ->
expr Pos.marked Bindlib.box
expr Marked.pos Bindlib.box
val make_let_in :
Var.t ->
Scopelang.Ast.typ Pos.marked ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box
Scopelang.Ast.typ Marked.pos ->
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box
(** {2 Rules and scopes}*)
type exception_situation =
| BaseCase
| ExceptionToLabel of LabelName.t Marked.pos
| ExceptionToRule of RuleName.t Marked.pos
type label_situation = ExplicitlyLabeled of LabelName.t Marked.pos | Unlabeled
type rule = {
rule_id : RuleName.t;
rule_just : expr Pos.marked Bindlib.box;
rule_cons : expr Pos.marked Bindlib.box;
rule_parameter : (Var.t * Scopelang.Ast.typ Pos.marked) option;
rule_exception_to_rules : RuleSet.t Pos.marked;
rule_just : expr Marked.pos Bindlib.box;
rule_cons : expr Marked.pos Bindlib.box;
rule_parameter : (Var.t * Scopelang.Ast.typ Marked.pos) option;
rule_exception : exception_situation;
rule_label : label_situation;
}
module Rule : Set.OrderedType with type t = rule
val empty_rule : Pos.t -> Scopelang.Ast.typ Pos.marked option -> rule
val always_false_rule : Pos.t -> Scopelang.Ast.typ Pos.marked option -> rule
val empty_rule : Pos.t -> Scopelang.Ast.typ Marked.pos option -> rule
val always_false_rule : Pos.t -> Scopelang.Ast.typ Marked.pos option -> rule
type assertion = expr Pos.marked Bindlib.box
type assertion = expr Marked.pos 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
| FixedBy of reference_typ Marked.pos
| VariesWith of unit * variation_typ Marked.pos option
type scope_def = {
scope_def_rules : rule RuleMap.t;
scope_def_typ : Scopelang.Ast.typ Pos.marked;
scope_def_typ : Scopelang.Ast.typ Marked.pos;
scope_def_is_condition : bool;
scope_def_io : Scopelang.Ast.io;
scope_def_label_groups : RuleSet.t LabelMap.t;
}
type var_or_states = WholeVar | States of StateName.t list
@ -179,5 +181,5 @@ type program = {
(** {1 Helpers} *)
val locations_used : expr Pos.marked -> LocationSet.t
val locations_used : expr Marked.pos -> LocationSet.t
val free_variables : rule RuleMap.t -> Pos.t ScopeDefMap.t

282
compiler/desugared/dependency.ml
View File

@ -129,10 +129,11 @@ let check_for_cycle (scope : Ast.scope) (g : ScopeDependencies.t) : unit =
in
[
( Some ("Cycle variable " ^ var_str ^ ", declared:"),
Pos.get_position var_info );
Marked.get_mark var_info );
( Some
("Used here in the definition of another cycle variable "
^ succ_str ^ ":"),
^ succ_str
^ ":"),
edge_pos );
])
scc)
@ -240,8 +241,17 @@ module ExceptionVertex = struct
let equal x y = compare x y = 0
end
module EdgeExceptions = struct
type t = Pos.t list
let compare = compare
let default = [Pos.no_pos]
end
module ExceptionsDependencies =
Graph.Persistent.Digraph.ConcreteBidirectionalLabeled (ExceptionVertex) (Edge)
Graph.Persistent.Digraph.ConcreteBidirectionalLabeled
(ExceptionVertex)
(EdgeExceptions)
(** Module of the graph, provided by OCamlGraph. [x -> y] if [y] is an exception
to [x] *)
@ -250,95 +260,190 @@ module ExceptionsSCC = Graph.Components.Make (ExceptionsDependencies)
(** {2 Graph computations} *)
type exception_edge = {
label_from : Ast.LabelName.t;
label_to : Ast.LabelName.t;
edge_positions : Pos.t list;
}
let build_exceptions_graph
(def : Ast.rule Ast.RuleMap.t)
(def_info : Ast.ScopeDef.t) : ExceptionsDependencies.t =
(* first we collect all the rule sets referred by exceptions *)
let all_rule_sets_pointed_to_by_exceptions : Ast.RuleSet.t list =
(* First we partition the definitions into groups bearing the same label. To
handle the rules that were not labeled by the user, we create implicit
labels. *)
(* All the rules of the form [definition x ...] are base case with no explicit
label, so they should share this implicit label. *)
let base_case_implicit_label =
Ast.LabelName.fresh ("base_case", Pos.no_pos)
in
(* When declaring [exception definition x ...], it means there is a unique
rule [R] to which this can be an exception to. So we give a unique label to
all the rules that are implicitly exceptions to rule [R]. *)
let exception_to_rule_implicit_labels : Ast.LabelName.t Ast.RuleMap.t =
Ast.RuleMap.fold
(fun _rule_name rule acc ->
if Ast.RuleSet.is_empty (Pos.unmark rule.Ast.rule_exception_to_rules)
then acc
else Pos.unmark rule.Ast.rule_exception_to_rules :: acc)
(fun _ rule_from exception_to_rule_implicit_labels ->
match rule_from.Ast.rule_exception with
| Ast.ExceptionToRule (rule_to, _) -> (
match
Ast.RuleMap.find_opt rule_to exception_to_rule_implicit_labels
with
| Some _ ->
(* we already created the label *) exception_to_rule_implicit_labels
| None ->
Ast.RuleMap.add rule_to
(Ast.LabelName.fresh
( "exception_to_"
^ Marked.unmark (Ast.RuleName.get_info rule_to),
Pos.no_pos ))
exception_to_rule_implicit_labels)
| _ -> exception_to_rule_implicit_labels)
def Ast.RuleMap.empty
in
(* When declaring [exception foo_l definition x ...], the rule is exception to
all the rules sharing label [foo_l]. So we give a unique label to all the
rules that are implicitly exceptions to rule [foo_l]. *)
let exception_to_label_implicit_labels : Ast.LabelName.t Ast.LabelMap.t =
Ast.RuleMap.fold
(fun _ rule_from
(exception_to_label_implicit_labels : Ast.LabelName.t Ast.LabelMap.t) ->
match rule_from.Ast.rule_exception with
| Ast.ExceptionToLabel (label_to, _) -> (
match
Ast.LabelMap.find_opt label_to exception_to_label_implicit_labels
with
| Some _ ->
(* we already created the label *)
exception_to_label_implicit_labels
| None ->
Ast.LabelMap.add label_to
(Ast.LabelName.fresh
( "exception_to_"
^ Marked.unmark (Ast.LabelName.get_info label_to),
Pos.no_pos ))
exception_to_label_implicit_labels)
| _ -> exception_to_label_implicit_labels)
def Ast.LabelMap.empty
in
(* Now we have all the labels necessary to partition our rules into sets, each
one corresponding to a label relating to the structure of the exception
DAG. *)
let label_to_rule_sets =
Ast.RuleMap.fold
(fun rule_name rule rule_sets ->
let label_of_rule =
match rule.Ast.rule_label with
| Ast.ExplicitlyLabeled (l, _) -> l
| Ast.Unlabeled -> (
match rule.Ast.rule_exception with
| BaseCase -> base_case_implicit_label
| ExceptionToRule (r, _) ->
Ast.RuleMap.find r exception_to_rule_implicit_labels
| ExceptionToLabel (l', _) ->
Ast.LabelMap.find l' exception_to_label_implicit_labels)
in
Ast.LabelMap.update label_of_rule
(fun rule_set ->
match rule_set with
| None -> Some (Ast.RuleSet.singleton rule_name)
| Some rule_set -> Some (Ast.RuleSet.add rule_name rule_set))
rule_sets)
def Ast.LabelMap.empty
in
let find_label_of_rule (r : Ast.RuleName.t) : Ast.LabelName.t =
fst
(Ast.LabelMap.choose
(Ast.LabelMap.filter
(fun _ rule_set -> Ast.RuleSet.mem r rule_set)
label_to_rule_sets))
in
(* Next, we collect the exception edges between those groups of rules referred
by their labels. This is also at this step that we check consistency of the
edges as they are declared at each rule but should be the same for all the
rules of the same group. *)
let exception_edges : exception_edge list =
Ast.RuleMap.fold
(fun rule_name rule exception_edges ->
let label_from = find_label_of_rule rule_name in
let label_to_and_pos =
match rule.Ast.rule_exception with
| Ast.BaseCase -> None
| Ast.ExceptionToRule (r', pos) -> Some (find_label_of_rule r', pos)
| Ast.ExceptionToLabel (l', pos) -> Some (l', pos)
in
match label_to_and_pos with
| None -> exception_edges
| Some (label_to, edge_pos) -> (
let other_edges_originating_from_same_label =
List.filter
(fun edge -> Ast.LabelName.compare edge.label_from label_from = 0)
exception_edges
in
(* We check the consistency*)
if Ast.LabelName.compare label_from label_to = 0 then
Errors.raise_spanned_error edge_pos
"Cannot define rule as an exception to itself";
List.iter
(fun edge ->
if Ast.LabelName.compare edge.label_to label_to <> 0 then
Errors.raise_multispanned_error
(( Some
"This declaration contradicts another exception \
declarations:",
edge_pos )
:: List.map
(fun pos ->
Some "Here is another exception declaration:", pos)
edge.edge_positions)
"The declaration of exceptions are inconsistent for variable \
%a."
Ast.ScopeDef.format_t def_info)
other_edges_originating_from_same_label;
(* Now we add the edge to the list*)
let existing_edge =
List.find_opt
(fun edge ->
Ast.LabelName.compare edge.label_from label_from = 0
&& Ast.LabelName.compare edge.label_to label_to = 0)
exception_edges
in
match existing_edge with
| None ->
{ label_from; label_to; edge_positions = [edge_pos] }
:: exception_edges
| Some existing_edge ->
{
label_from;
label_to;
edge_positions = edge_pos :: existing_edge.edge_positions;
}
:: List.filter (fun edge -> edge <> existing_edge) exception_edges))
def []
in
(* we make sure these sets are either disjoint or equal ; should be a
syntactic invariant since you currently can't assign two labels to a single
rule but an extra check is valuable since this is a required invariant for
the graph to be sound *)
List.iter
(fun rule_set1 ->
List.iter
(fun rule_set2 ->
if Ast.RuleSet.equal rule_set1 rule_set2 then ()
else if Ast.RuleSet.disjoint rule_set1 rule_set2 then ()
else
let spans =
List.of_seq
(Seq.map
(fun rule ->
( Some "Rule or definition from the first group:",
Pos.get_position (Ast.RuleName.get_info rule) ))
(Ast.RuleSet.to_seq rule_set1))
@ List.of_seq
(Seq.map
(fun rule ->
( Some "Rule or definition from the second group:",
Pos.get_position (Ast.RuleName.get_info rule) ))
(Ast.RuleSet.to_seq rule_set2))
in
Errors.raise_multispanned_error spans
"Definitions or rules grouped by different labels overlap, \
whereas these groups shoule be disjoint")
all_rule_sets_pointed_to_by_exceptions)
all_rule_sets_pointed_to_by_exceptions;
(* Then we add the exception graph vertices by taking all those sets of rules
pointed to by exceptions, and adding the remaining rules not pointed as
separate singleton set vertices *)
(* We've got the vertices and the edges, let's build the graph! *)
let g =
List.fold_left
(fun g rule_set -> ExceptionsDependencies.add_vertex g rule_set)
ExceptionsDependencies.empty all_rule_sets_pointed_to_by_exceptions
in
let g =
Ast.RuleMap.fold
(fun (rule_name : Ast.RuleName.t) _ g ->
if
List.exists
(fun rule_set_pointed_to_by_exceptions ->
Ast.RuleSet.mem rule_name rule_set_pointed_to_by_exceptions)
all_rule_sets_pointed_to_by_exceptions
then g
else
ExceptionsDependencies.add_vertex g (Ast.RuleSet.singleton rule_name))
def g
Ast.LabelMap.fold
(fun _label rule_set g -> ExceptionsDependencies.add_vertex g rule_set)
label_to_rule_sets ExceptionsDependencies.empty
in
(* then we add the edges *)
let g =
Ast.RuleMap.fold
(fun rule_name rule g ->
(* Right now, exceptions can only consist of one rule, we may want to
relax that constraint later in the development of Catala. *)
let exception_to_ruleset, pos = rule.Ast.rule_exception_to_rules in
if Ast.RuleSet.is_empty exception_to_ruleset then g
(* we don't add an edge*)
else if ExceptionsDependencies.mem_vertex g exception_to_ruleset then
if exception_to_ruleset = Ast.RuleSet.singleton rule_name then
Errors.raise_spanned_error pos
"Cannot define rule as an exception to itself"
else
let edge =
ExceptionsDependencies.E.create
(Ast.RuleSet.singleton rule_name)
pos exception_to_ruleset
in
ExceptionsDependencies.add_edge_e g edge
else
Errors.raise_spanned_error pos
"This rule has been declared as an exception to an incorrect \
label: this label is not attached to a definition of \"%a\""
Ast.ScopeDef.format_t def_info)
def g
List.fold_left
(fun g edge ->
let rule_group_from =
Ast.LabelMap.find edge.label_from label_to_rule_sets
in
let rule_group_to =
Ast.LabelMap.find edge.label_to label_to_rule_sets
in
let edge =
ExceptionsDependencies.E.create rule_group_from edge.edge_positions
rule_group_to
in
ExceptionsDependencies.add_edge_e g edge)
g exception_edges
in
g
@ -364,13 +469,16 @@ let check_for_exception_cycle (g : ExceptionsDependencies.t) : unit =
in
[
( Some
("Cyclic exception for definition of variable \"" ^ var_str
^ "\", declared here:"),
Pos.get_position var_info );
("Cyclic exception for definition of variable \""
^ var_str
^ "\", declared here:"),
Marked.get_mark var_info );
( Some
("Used here in the definition of another cyclic exception \
for defining \"" ^ var_str ^ "\":"),
edge_pos );
for defining \""
^ var_str
^ "\":"),
List.hd edge_pos );
])
scc)
in

4
compiler/desugared/dependency.mli
View File

@ -68,8 +68,10 @@ val build_scope_dependencies : Ast.scope -> ScopeDependencies.t
(** {1 Exceptions dependency graph} *)
module EdgeExceptions : Graph.Sig.ORDERED_TYPE_DFT with type t = Pos.t list
module ExceptionsDependencies :
Graph.Sig.P with type V.t = Ast.RuleSet.t and type E.label = Edge.t
Graph.Sig.P with type V.t = Ast.RuleSet.t and type E.label = EdgeExceptions.t
val build_exceptions_graph :
Ast.rule Ast.RuleMap.t -> Ast.ScopeDef.t -> ExceptionsDependencies.t

185
compiler/desugared/desugared_to_scope.ml
View File

@ -30,84 +30,83 @@ type ctx = {
}
let tag_with_log_entry
(e : Scopelang.Ast.expr Pos.marked)
(e : Scopelang.Ast.expr Marked.pos)
(l : Dcalc.Ast.log_entry)
(markings : Utils.Uid.MarkedString.info list) :
Scopelang.Ast.expr Pos.marked =
Scopelang.Ast.expr Marked.pos =
( Scopelang.Ast.EApp
( ( Scopelang.Ast.EOp (Dcalc.Ast.Unop (Dcalc.Ast.Log (l, markings))),
Pos.get_position e ),
Marked.get_mark e ),
[e] ),
Pos.get_position e )
Marked.get_mark e )
let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) :
Scopelang.Ast.expr Pos.marked Bindlib.box =
match Pos.unmark e with
let rec translate_expr (ctx : ctx) (e : Ast.expr Marked.pos) :
Scopelang.Ast.expr Marked.pos Bindlib.box =
let m = Marked.get_mark e in
match Marked.unmark e with
| Ast.ELocation (SubScopeVar (s_name, ss_name, s_var)) ->
(* When referring to a subscope variable in an expression, we are referring
to the output, hence we take the last state. *)
let new_s_var =
match Ast.ScopeVarMap.find (Pos.unmark s_var) ctx.scope_var_mapping with
| WholeVar new_s_var -> Pos.same_pos_as new_s_var s_var
| States states -> Pos.same_pos_as (snd (List.hd (List.rev states))) s_var
match
Ast.ScopeVarMap.find (Marked.unmark s_var) ctx.scope_var_mapping
with
| WholeVar new_s_var -> Marked.same_mark_as new_s_var s_var
| States states ->
Marked.same_mark_as (snd (List.hd (List.rev states))) s_var
in
Bindlib.box
( Scopelang.Ast.ELocation (SubScopeVar (s_name, ss_name, new_s_var)),
Pos.get_position e )
(Scopelang.Ast.ELocation (SubScopeVar (s_name, ss_name, new_s_var)), m)
| Ast.ELocation (ScopeVar (s_var, None)) ->
Bindlib.box
( Scopelang.Ast.ELocation
(ScopeVar
(match
Ast.ScopeVarMap.find (Pos.unmark s_var) ctx.scope_var_mapping
Ast.ScopeVarMap.find (Marked.unmark s_var) ctx.scope_var_mapping
with
| WholeVar new_s_var -> Pos.same_pos_as new_s_var s_var
| WholeVar new_s_var -> Marked.same_mark_as new_s_var s_var
| States _ -> failwith "should not happen")),
Pos.get_position e )
m )
| Ast.ELocation (ScopeVar (s_var, Some state)) ->
Bindlib.box
( Scopelang.Ast.ELocation
(ScopeVar
(match
Ast.ScopeVarMap.find (Pos.unmark s_var) ctx.scope_var_mapping
Ast.ScopeVarMap.find (Marked.unmark s_var) ctx.scope_var_mapping
with
| WholeVar _ -> failwith "should not happen"
| States states -> Pos.same_pos_as (List.assoc state states) s_var)),
Pos.get_position e )
| States states ->
Marked.same_mark_as (List.assoc state states) s_var)),
m )
| Ast.EVar v ->
Bindlib.box_apply
(fun v -> Pos.same_pos_as v e)
(Bindlib.box_var (Ast.VarMap.find (Pos.unmark v) ctx.var_mapping))
(fun v -> Marked.same_mark_as v e)
(Bindlib.box_var (Ast.VarMap.find v ctx.var_mapping))
| EStruct (s_name, fields) ->
Bindlib.box_apply
(fun new_fields ->
Scopelang.Ast.EStruct (s_name, new_fields), Pos.get_position e)
(fun new_fields -> Scopelang.Ast.EStruct (s_name, new_fields), m)
(Scopelang.Ast.StructFieldMapLift.lift_box
(Scopelang.Ast.StructFieldMap.map (translate_expr ctx) fields))
| EStructAccess (e1, s_name, f_name) ->
Bindlib.box_apply
(fun new_e1 ->
Scopelang.Ast.EStructAccess (new_e1, s_name, f_name), Pos.get_position e)
(fun new_e1 -> Scopelang.Ast.EStructAccess (new_e1, s_name, f_name), m)
(translate_expr ctx e1)
| EEnumInj (e1, cons, e_name) ->
Bindlib.box_apply
(fun new_e1 ->
Scopelang.Ast.EEnumInj (new_e1, cons, e_name), Pos.get_position e)
(fun new_e1 -> Scopelang.Ast.EEnumInj (new_e1, cons, e_name), m)
(translate_expr ctx e1)
| EMatch (e1, e_name, arms) ->
Bindlib.box_apply2
(fun new_e1 new_arms ->
Scopelang.Ast.EMatch (new_e1, e_name, new_arms), Pos.get_position e)
Scopelang.Ast.EMatch (new_e1, e_name, new_arms), m)
(translate_expr ctx e1)
(Scopelang.Ast.EnumConstructorMapLift.lift_box
(Scopelang.Ast.EnumConstructorMap.map (translate_expr ctx) arms))
| ELit l -> Bindlib.box (Scopelang.Ast.ELit l, Pos.get_position e)
| EAbs ((binder, binder_pos), typs) ->
| ELit l -> Bindlib.box (Scopelang.Ast.ELit l, m)
| EAbs (binder, typs) ->
let vars, body = Bindlib.unmbind binder in
let new_vars =
Array.map
(fun var -> Scopelang.Ast.Var.make (Bindlib.name_of var, binder_pos))
vars
Array.map (fun var -> Scopelang.Ast.Var.make (Bindlib.name_of var)) vars
in
let ctx =
List.fold_left2
@ -116,35 +115,32 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) :
ctx (Array.to_list vars) (Array.to_list new_vars)
in
Bindlib.box_apply
(fun new_binder ->
Scopelang.Ast.EAbs ((new_binder, binder_pos), typs), Pos.get_position e)
(fun new_binder -> Scopelang.Ast.EAbs (new_binder, typs), m)
(Bindlib.bind_mvar new_vars (translate_expr ctx body))
| EApp (e1, args) ->
Bindlib.box_apply2
(fun new_e1 new_args ->
Scopelang.Ast.EApp (new_e1, new_args), Pos.get_position e)
(fun new_e1 new_args -> Scopelang.Ast.EApp (new_e1, new_args), m)
(translate_expr ctx e1)
(Bindlib.box_list (List.map (translate_expr ctx) args))
| EOp op -> Bindlib.box (Scopelang.Ast.EOp op, Pos.get_position e)
| EOp op -> Bindlib.box (Scopelang.Ast.EOp op, m)
| EDefault (excepts, just, cons) ->
Bindlib.box_apply3
(fun new_excepts new_just new_cons ->
Scopelang.Ast.make_default ~pos:(Pos.get_position e) new_excepts
new_just new_cons)
Scopelang.Ast.make_default ~pos:m new_excepts new_just new_cons)
(Bindlib.box_list (List.map (translate_expr ctx) excepts))
(translate_expr ctx just) (translate_expr ctx cons)
| EIfThenElse (e1, e2, e3) ->
Bindlib.box_apply3
(fun new_e1 new_e2 new_e3 ->
Scopelang.Ast.EIfThenElse (new_e1, new_e2, new_e3), Pos.get_position e)
Scopelang.Ast.EIfThenElse (new_e1, new_e2, new_e3), m)
(translate_expr ctx e1) (translate_expr ctx e2) (translate_expr ctx e3)
| EArray args ->
Bindlib.box_apply
(fun new_args -> Scopelang.Ast.EArray new_args, Pos.get_position e)
(fun new_args -> Scopelang.Ast.EArray new_args, m)
(Bindlib.box_list (List.map (translate_expr ctx) args))
| ErrorOnEmpty e1 ->
Bindlib.box_apply
(fun new_e1 -> Scopelang.Ast.ErrorOnEmpty new_e1, Pos.get_position e)
(fun new_e1 -> Scopelang.Ast.ErrorOnEmpty new_e1, m)
(translate_expr ctx e1)
(** {1 Rule tree construction} *)
@ -155,8 +151,8 @@ type rule_tree =
| Leaf of Ast.rule list
(** Rules defining a base case piecewise. List is non-empty. *)
| Node of rule_tree list * Ast.rule list
(** A list of exceptions to a non-empty list of rules defining a base case
piecewise. *)
(** [Node (exceptions, base_case)] is a list of exceptions to a non-empty
list of rules defining a base case piecewise. *)
(** Transforms a flat list of rules into a tree, taking into account the
priorities declared between rules *)
@ -197,7 +193,7 @@ let rec rule_tree_to_expr
(ctx : ctx)
(def_pos : Pos.t)
(is_func : Ast.Var.t option)
(tree : rule_tree) : Scopelang.Ast.expr Pos.marked Bindlib.box =
(tree : rule_tree) : Scopelang.Ast.expr Marked.pos Bindlib.box =
let exceptions, base_rules =
match tree with Leaf r -> [], r | Node (exceptions, r) -> exceptions, r
in
@ -205,8 +201,8 @@ let rec rule_tree_to_expr
whole rule tree into a function, we need to perform some alpha-renaming of
all the expressions *)
let substitute_parameter
(e : Ast.expr Pos.marked Bindlib.box)
(rule : Ast.rule) : Ast.expr Pos.marked Bindlib.box =
(e : Ast.expr Marked.pos Bindlib.box)
(rule : Ast.rule) : Ast.expr Marked.pos Bindlib.box =
match is_func, rule.Ast.rule_parameter with
| Some new_param, Some (old_param, _) ->
let binder = Bindlib.bind_var old_param e in
@ -225,7 +221,7 @@ let rec rule_tree_to_expr
match Ast.VarMap.find_opt new_param ctx.var_mapping with
| None ->
let new_param_scope =
Scopelang.Ast.Var.make (Bindlib.name_of new_param, def_pos)
Scopelang.Ast.Var.make (Bindlib.name_of new_param)
in
{
ctx with
@ -248,8 +244,8 @@ let rec rule_tree_to_expr
(fun rule -> substitute_parameter rule.Ast.rule_cons rule)
base_rules
in
let translate_and_unbox_list (list : Ast.expr Pos.marked Bindlib.box list) :
Scopelang.Ast.expr Pos.marked Bindlib.box list =
let translate_and_unbox_list (list : Ast.expr Marked.pos Bindlib.box list) :
Scopelang.Ast.expr Marked.pos Bindlib.box list =
List.map
(fun e ->
(* There are two levels of boxing here, the outermost is introduced by
@ -303,7 +299,7 @@ let rec rule_tree_to_expr
in
Scopelang.Ast.make_abs
(Array.of_list [Ast.VarMap.find new_param ctx.var_mapping])
default def_pos [typ] def_pos
default [typ] def_pos
else default
| _ -> (* should not happen *) assert false
@ -315,13 +311,15 @@ let translate_def
(ctx : ctx)
(def_info : Ast.ScopeDef.t)
(def : Ast.rule Ast.RuleMap.t)
(typ : Scopelang.Ast.typ Pos.marked)
(typ : Scopelang.Ast.typ Marked.pos)
(io : Scopelang.Ast.io)
~(is_cond : bool)
~(is_subscope_var : bool) : Scopelang.Ast.expr Pos.marked =
~(is_subscope_var : bool) : Scopelang.Ast.expr Marked.pos =
(* Here, we have to transform this list of rules into a default tree. *)
let is_def_func =
match Pos.unmark typ with Scopelang.Ast.TArrow (_, _) -> true | _ -> false
match Marked.unmark typ with
| Scopelang.Ast.TArrow (_, _) -> true
| _ -> false
in
let is_rule_func _ (r : Ast.rule) : bool =
Option.is_some r.Ast.rule_parameter
@ -330,12 +328,12 @@ let translate_def
let all_rules_not_func =
Ast.RuleMap.for_all (fun n r -> not (is_rule_func n r)) def
in
let is_def_func_param_typ : Scopelang.Ast.typ Pos.marked option =
let is_def_func_param_typ : Scopelang.Ast.typ Marked.pos option =
if is_def_func && all_rules_func then
match Pos.unmark typ with
match Marked.unmark typ with
| Scopelang.Ast.TArrow (t_param, _) -> Some t_param
| _ ->
Errors.raise_spanned_error (Pos.get_position typ)
Errors.raise_spanned_error (Marked.get_mark typ)
"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
@ -345,12 +343,12 @@ let translate_def
List.map
(fun (_, r) ->
( Some "This definition is a function:",
Pos.get_position (Bindlib.unbox r.Ast.rule_cons) ))
Marked.get_mark (Bindlib.unbox r.Ast.rule_cons) ))
(Ast.RuleMap.bindings (Ast.RuleMap.filter is_rule_func def))
@ List.map
(fun (_, r) ->
( Some "This definition is not a function:",
Pos.get_position (Bindlib.unbox r.Ast.rule_cons) ))
Marked.get_mark (Bindlib.unbox r.Ast.rule_cons) ))
(Ast.RuleMap.bindings
(Ast.RuleMap.filter (fun n r -> not (is_rule_func n r)) def))
in
@ -360,8 +358,12 @@ let translate_def
in
let top_list = def_map_to_tree def_info def in
let top_value =
(if is_cond then Ast.always_false_rule else Ast.empty_rule)
(Pos.get_position typ) is_def_func_param_typ
if is_cond then
Some
(Ast.always_false_rule
(Ast.ScopeDef.get_position def_info)
is_def_func_param_typ)
else None
in
if
Ast.RuleMap.cardinal def = 0
@ -386,27 +388,37 @@ let translate_def
&& not
(is_cond
&&
match Pos.unmark io.Scopelang.Ast.io_input with
match Marked.unmark io.Scopelang.Ast.io_input with
| OnlyInput -> true
| _ -> false)
(* However, this special case suffers from an exception: when a condition is
defined as an OnlyInput to a subscope, since the [false] default value
will not be provided by the calee scope, it has to be placed in the
caller. *)
then ELit LEmptyError, Pos.no_pos
then ELit LEmptyError, Ast.ScopeDef.get_position def_info
else
Bindlib.unbox
(rule_tree_to_expr ~toplevel:true ctx
(Ast.ScopeDef.get_position def_info)
(Option.map
(fun _ ->
Ast.Var.make ("param", Ast.ScopeDef.get_position def_info))
is_def_func_param_typ)
(match top_list with
| [] ->
(* In this case, there are no rules to define the expression *)
(Option.map (fun _ -> Ast.Var.make "param") is_def_func_param_typ)
(match top_list, top_value with
| [], None ->
(* In this case, there are no rules to define the expression and no
default value so we put an empty rule. *)
Leaf [Ast.empty_rule (Marked.get_mark typ) is_def_func_param_typ]
| [], Some top_value ->
(* In this case, there are no rules to define the expression but a
default value so we put it. *)
Leaf [top_value]
| _ -> Node (top_list, [top_value])))
| _, Some top_value ->
(* When there are rules + a default value, we put the rules as
exceptions to the default value *)
Node (top_list, [top_value])
| [top_tree], None -> top_tree
| _, None ->
Node
( top_list,
[Ast.empty_rule (Marked.get_mark typ) is_def_func_param_typ] )))
(** Translates a scope *)
let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl =
@ -429,17 +441,17 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl =
let var_def = scope_def.scope_def_rules in
let var_typ = scope_def.scope_def_typ in
let is_cond = scope_def.scope_def_is_condition in
match Pos.unmark scope_def.Ast.scope_def_io.io_input with
match Marked.unmark scope_def.Ast.scope_def_io.io_input with
| OnlyInput when not (Ast.RuleMap.is_empty var_def) ->
(* If the variable is tagged as input, then it shall not be
redefined. *)
Errors.raise_multispanned_error
(( Some "Incriminated variable:",
Pos.get_position (Ast.ScopeVar.get_info var) )
Marked.get_mark (Ast.ScopeVar.get_info var) )
:: List.map
(fun (rule, _) ->
( Some "Incriminated variable definition:",
Pos.get_position (Ast.RuleName.get_info rule) ))
Marked.get_mark (Ast.RuleName.get_info rule) ))
(Ast.RuleMap.bindings var_def))
"It is impossible to give a definition to a scope variable \
tagged as input."
@ -465,9 +477,9 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl =
Scopelang.Ast.Definition
( ( Scopelang.Ast.ScopeVar
( scope_var,
Pos.get_position
Marked.get_mark
(Scopelang.Ast.ScopeVar.get_info scope_var) ),
Pos.get_position
Marked.get_mark
(Scopelang.Ast.ScopeVar.get_info scope_var) ),
var_typ,
scope_def.Ast.scope_def_io,
@ -491,7 +503,7 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl =
and are not visible in the input of the subscope *)
&& not
((match
Pos.unmark scope_def.Ast.scope_def_io.io_input
Marked.unmark scope_def.Ast.scope_def_io.io_input
with
| Scopelang.Ast.NoInput -> true
| _ -> false)
@ -511,20 +523,21 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl =
subscope. But we have to check that this redefinition is
allowed with respect to the io parameters of that
subscope variable. *)
(match Pos.unmark scope_def.Ast.scope_def_io.io_input with
(match
Marked.unmark scope_def.Ast.scope_def_io.io_input
with
| Scopelang.Ast.NoInput ->
Errors.raise_multispanned_error
(( Some "Incriminated subscope:",
Ast.ScopeDef.get_position def_key )
:: ( Some "Incriminated variable:",
Pos.get_position
Marked.get_mark
(Ast.ScopeVar.get_info sub_scope_var) )
:: List.map
(fun (rule, _) ->
( Some
"Incriminated subscope variable definition:",
Pos.get_position (Ast.RuleName.get_info rule)
))
Marked.get_mark (Ast.RuleName.get_info rule) ))
(Ast.RuleMap.bindings def))
"It is impossible to give a definition to a subscope \
variable not tagged as input or context."
@ -536,7 +549,7 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl =
( Some "Incriminated subscope:",
Ast.ScopeDef.get_position def_key );
( Some "Incriminated variable:",
Pos.get_position
Marked.get_mark
(Ast.ScopeVar.get_info sub_scope_var) );
]
"This subscope variable is a mandatory input but no \
@ -554,7 +567,7 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl =
scope.scope_sub_scopes
in
let var_pos =
Pos.get_position (Ast.ScopeVar.get_info sub_scope_var)
Marked.get_mark (Ast.ScopeVar.get_info sub_scope_var)
in
Scopelang.Ast.Definition
( ( Scopelang.Ast.SubScopeVar
@ -673,8 +686,10 @@ let translate_program (pgrm : Ast.program) : Scopelang.Ast.program =
(let state_name, state_pos =
Ast.StateName.get_info state
in
( Pos.unmark (Ast.ScopeVar.get_info scope_var)
^ "_" ^ state_name,
( Marked.unmark
(Ast.ScopeVar.get_info scope_var)
^ "_"
^ state_name,
state_pos )) ))
states))
ctx.scope_var_mapping;

92
compiler/driver.ml
View File

@ -81,20 +81,12 @@ let driver source_file (options : Cli.options) : int =
Surface.Parser_driver.parse_top_level_file source_file language
in
let prgm = Surface.Fill_positions.fill_pos_with_legislative_info prgm in
let get_output ?ext () =
match options.output_file, ext with
| Some "-", _ | None, None -> None, fun f -> f stdout
| Some f, _ -> Some f, File.with_out_channel f
| None, Some ext ->
let src =
match source_file with FileName f -> f | Contents _ -> "a"
in
let f = Filename.remove_extension src ^ ext in
Some f, File.with_out_channel f
let get_output ?ext =
File.get_out_channel ~source_file ~output_file:options.output_file ?ext
in
let get_output_format ?ext () =
let f, with_ = get_output ?ext () in
f, fun f -> with_ (fun oc -> File.with_formatter_of_out_channel oc f)
let get_output_format ?ext =
File.get_formatter_of_out_channel ~source_file
~output_file:options.output_file ?ext
in
(match backend with
| `Makefile ->
@ -109,7 +101,8 @@ let driver source_file (options : Cli.options) : int =
let output_file, with_output = get_output ~ext:".d" () in
Cli.debug_print "Writing list of dependencies to %s..."
(Option.value ~default:"stdout" output_file);
with_output @@ fun oc ->
with_output
@@ fun oc ->
Printf.fprintf oc "%s:\\\n%s\n%s:"
(String.concat "\\\n"
(Option.value ~default:"stdout" output_file
@ -173,7 +166,8 @@ let driver source_file (options : Cli.options) : int =
match backend with
| `Scopelang ->
let _output_file, with_output = get_output_format () in
with_output @@ fun fmt ->
with_output
@@ fun fmt ->
if Option.is_some options.ex_scope then
Format.fprintf fmt "%a\n"
(Scopelang.Print.format_scope ~debug:options.debug)
@ -196,13 +190,11 @@ let driver source_file (options : Cli.options) : int =
end
else prgm
in
let prgrm_dcalc_expr =
Bindlib.unbox (Dcalc.Ast.build_whole_program_expr prgm scope_uid)
in
match backend with
| `Dcalc ->
let _output_file, with_output = get_output_format () in
with_output @@ fun fmt ->
with_output
@@ fun fmt ->
if Option.is_some options.ex_scope then
Format.fprintf fmt "%a\n"
(Dcalc.Print.format_scope ~debug:options.debug prgm.decl_ctx)
@ -218,13 +210,19 @@ let driver source_file (options : Cli.options) : int =
else acc)
prgm.scopes) )
else
let prgrm_dcalc_expr =
Bindlib.unbox
(Dcalc.Ast.build_whole_program_expr ~box_expr:Dcalc.Ast.box_expr
~make_abs:Dcalc.Ast.make_abs
~make_let_in:Dcalc.Ast.make_let_in prgm scope_uid)
in
Format.fprintf fmt "%a\n"
(Dcalc.Print.format_expr prgm.decl_ctx)
prgrm_dcalc_expr
| ( `Interpret | `Typecheck | `OCaml | `Python | `Scalc | `Lcalc
| `Proof | `Plugin _ ) as backend -> (
Cli.debug_print "Typechecking...";
let _typ = Dcalc.Typing.infer_type prgm.decl_ctx prgrm_dcalc_expr in
let prgm = Dcalc.Typing.infer_types_program prgm in
(* Cli.debug_print (Format.asprintf "Typechecking results :@\n%a"
(Dcalc.Print.format_typ prgm.decl_ctx) typ); *)
match backend with
@ -242,6 +240,12 @@ let driver source_file (options : Cli.options) : int =
Verification.Solver.solve_vc prgm.decl_ctx vcs
| `Interpret ->
Cli.debug_print "Starting interpretation...";
let prgrm_dcalc_expr =
Bindlib.unbox
(Dcalc.Ast.build_whole_program_expr ~box_expr:Dcalc.Ast.box_expr
~make_abs:Dcalc.Ast.make_abs
~make_let_in:Dcalc.Ast.make_let_in prgm scope_uid)
in
let results =
Dcalc.Interpreter.interpret_program prgm.decl_ctx prgrm_dcalc_expr
in
@ -281,7 +285,7 @@ let driver source_file (options : Cli.options) : int =
Cli.debug_print "Optimizing lambda calculus...";
Lcalc.Optimizations.optimize_program prgm
end
else prgm
else Lcalc.Ast.untype_program prgm
in
let prgm =
if options.closure_conversion then (
@ -294,7 +298,8 @@ let driver source_file (options : Cli.options) : int =
match backend with
| `Lcalc ->
let _output_file, with_output = get_output_format () in
with_output @@ fun fmt ->
with_output
@@ fun fmt ->
if Option.is_some options.ex_scope then
Format.fprintf fmt "%a\n"
(Lcalc.Print.format_scope ~debug:options.debug prgm.decl_ctx)
@ -310,39 +315,42 @@ let driver source_file (options : Cli.options) : int =
else acc)
prgm.scopes) )
else
ignore
(Dcalc.Ast.fold_left_scope_defs ~init:0
~f:(fun i scope_def _ ->
Format.fprintf fmt "%s%a"
(if i = 0 then "" else "\n")
(Lcalc.Print.format_scope prgm.decl_ctx)
(scope_uid, scope_def.scope_body);
i + 1)
prgm.scopes)
let prgrm_lcalc_expr =
Bindlib.unbox
(Dcalc.Ast.build_whole_program_expr
~box_expr:Lcalc.Ast.box_expr ~make_abs:Lcalc.Ast.make_abs
~make_let_in:Lcalc.Ast.make_let_in prgm scope_uid)
in
Format.fprintf fmt "%a\n"
(Lcalc.Print.format_expr prgm.decl_ctx)
prgrm_lcalc_expr
| (`OCaml | `Python | `Scalc | `Plugin _) as backend -> (
match backend with
| `OCaml ->
let output_file, with_output =
get_output_format ~ext:".ml" ()
in
with_output @@ fun fmt ->
with_output
@@ fun fmt ->
Cli.debug_print "Compiling program into OCaml...";
Cli.debug_print "Writing to %s..."
(Option.value ~default:"stdout" output_file);
Lcalc.To_ocaml.format_program fmt prgm type_ordering
| `Plugin (Plugin.Lcalc p) ->
let output_file, _ = get_output ~ext:p.Plugin.extension () in
let output_file, _ =
get_output_format ~ext:p.Plugin.extension ()
in
Cli.debug_print "Compiling program through backend \"%s\"..."
p.Plugin.name;
Cli.debug_print "Writing to %s..."
(Option.value ~default:"stdout" output_file);
p.Plugin.apply output_file prgm type_ordering
p.Plugin.apply ~source_file ~output_file ~scope:options.ex_scope
prgm type_ordering
| (`Python | `Scalc | `Plugin (Plugin.Scalc _)) as backend -> (
let prgm = Scalc.Compile_from_lambda.translate_program prgm in
match backend with
| `Scalc ->
let _output_file, with_output = get_output_format () in
with_output @@ fun fmt ->
with_output
@@ fun fmt ->
if Option.is_some options.ex_scope then
Format.fprintf fmt "%a\n"
(Scalc.Print.format_scope ~debug:options.debug
@ -365,7 +373,8 @@ let driver source_file (options : Cli.options) : int =
Cli.debug_print "Compiling program into Python...";
Cli.debug_print "Writing to %s..."
(Option.value ~default:"stdout" output_file);
with_output @@ fun fmt ->
with_output
@@ fun fmt ->
Scalc.To_python.format_program fmt prgm type_ordering
| `Plugin (Plugin.Lcalc _) -> assert false
| `Plugin (Plugin.Scalc p) ->
@ -374,14 +383,19 @@ let driver source_file (options : Cli.options) : int =
p.Plugin.name;
Cli.debug_print "Writing to %s..."
(Option.value ~default:"stdout" output_file);
p.Plugin.apply output_file prgm type_ordering)))))));
p.Plugin.apply ~source_file ~output_file
~scope:options.ex_scope prgm type_ordering)))))));
0
with
| Errors.StructuredError (msg, pos) ->
let bt = Printexc.get_raw_backtrace () in
Cli.error_print "%s" (Errors.print_structured_error msg pos);
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
-1
| Sys_error msg ->
let bt = Printexc.get_raw_backtrace () in
Cli.error_print "System error: %s" msg;
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
-1
let main () =

27
compiler/dune
View File

@ -10,18 +10,10 @@
dcalc
lcalc
scalc
runtime
catala.runtime_ocaml
verification)
(modules plugin driver))
(library
(name runtime)
(public_name catala.runtime)
(preprocess
(pps ppx_yojson_conv))
(libraries dates_calc zarith zarith_stubs_js)
(modules runtime))
(executable
(name catala_web_interpreter)
(modes byte js)
@ -30,11 +22,26 @@
(modules catala_web_interpreter)
(preprocess
(pps js_of_ocaml-ppx))
(libraries catala.driver js_of_ocaml))
(libraries
catala.driver
js_of_ocaml
catala.runtime_ocaml
catala.runtime_jsoo))
(rule
(target custom_linking.sexp)
(mode fallback)
(action
(with-stdout-to
%{target}
(echo "()"))))
(executable
(name catala)
(modes native js)
(flags
(:standard
(:include custom_linking.sexp)))
(package catala)
(modules catala)
(public_name catala)

4
compiler/index.mld
View File

@ -106,9 +106,9 @@ Two more modules contain additional features for the compiler:
{li {{: utils.html} Compiler utilities}}
}
The Catala runtime documentation is available here:
The Catala runtimes documentation is available here:
{!modules: Runtime}
{!modules: Runtime_ocaml.Runtime Runtime_jsoo.Runtime}
Last, it is possible to customize the backend to the compiler using a plugin
mechanism. The API is defined inside the following module:

343
compiler/lcalc/ast.ml
View File

@ -15,6 +15,7 @@
the License. *)
open Utils
module Runtime = Runtime_ocaml.Runtime
module D = Dcalc.Ast
type lit =
@ -27,197 +28,181 @@ type lit =
| LDuration of Runtime.duration
type except = ConflictError | EmptyError | NoValueProvided | Crash
type 'm mark = 'm D.mark
type expr =
| EVar of expr Bindlib.var Pos.marked
| ETuple of expr Pos.marked list * D.StructName.t option
type 'm marked_expr = ('m expr, 'm) D.marked
and 'm expr =
| EVar of 'm expr Bindlib.var
| ETuple of 'm marked_expr list * D.StructName.t option
(** The [MarkedString.info] is the former struct field name*)
| ETupleAccess of
expr Pos.marked * int * D.StructName.t option * D.typ Pos.marked list
'm marked_expr * int * D.StructName.t option * D.typ Marked.pos list
(** The [MarkedString.info] is the former struct field name *)
| EInj of expr Pos.marked * int * D.EnumName.t * D.typ Pos.marked list
| EInj of 'm marked_expr * int * D.EnumName.t * D.typ Marked.pos list
(** The [MarkedString.info] is the former enum case name *)
| EMatch of expr Pos.marked * expr Pos.marked list * D.EnumName.t
| EMatch of 'm marked_expr * 'm marked_expr list * D.EnumName.t
(** The [MarkedString.info] is the former enum case name *)
| EArray of expr Pos.marked list
| EArray of 'm marked_expr list
| ELit of lit
| EAbs of
(expr, expr Pos.marked) Bindlib.mbinder Pos.marked * D.typ Pos.marked list
| EApp of expr Pos.marked * expr Pos.marked list
| EAssert of expr Pos.marked
| EAbs of ('m expr, 'm marked_expr) Bindlib.mbinder * D.typ Marked.pos list
| EApp of 'm marked_expr * 'm marked_expr list
| EAssert of 'm marked_expr
| EOp of D.operator
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
| EIfThenElse of 'm marked_expr * 'm marked_expr * 'm marked_expr
| ERaise of except
| ECatch of expr Pos.marked * except * expr Pos.marked
| ECatch of 'm marked_expr * except * 'm marked_expr
type program = { decl_ctx : Dcalc.Ast.decl_ctx; scopes : expr Dcalc.Ast.scopes }
type 'm program = ('m expr, 'm) Dcalc.Ast.program_generic
let evar (v : expr Bindlib.var) (pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun v' -> v', pos) (Bindlib.box_var v)
(* <copy-paste from dcalc/ast.ml> *)
let etuple
(args : expr Pos.marked Bindlib.box list)
(s : Dcalc.Ast.StructName.t option)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun args -> ETuple (args, s), pos) (Bindlib.box_list args)
let evar v mark = Bindlib.box_apply (Marked.mark mark) (Bindlib.box_var v)
let etupleaccess
(e1 : expr Pos.marked Bindlib.box)
(i : int)
(s : Dcalc.Ast.StructName.t option)
(typs : Dcalc.Ast.typ Pos.marked list)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun e1 -> ETupleAccess (e1, i, s, typs), pos) e1
let etuple args s mark =
Bindlib.box_apply (fun args -> ETuple (args, s), mark) (Bindlib.box_list args)
let einj
(e1 : expr Pos.marked Bindlib.box)
(i : int)
(e_name : Dcalc.Ast.EnumName.t)
(typs : Dcalc.Ast.typ Pos.marked list)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun e1 -> EInj (e1, i, e_name, typs), pos) e1
let etupleaccess e1 i s typs mark =
Bindlib.box_apply (fun e1 -> ETupleAccess (e1, i, s, typs), mark) e1
let ematch
(arg : expr Pos.marked Bindlib.box)
(arms : expr Pos.marked Bindlib.box list)
(e_name : Dcalc.Ast.EnumName.t)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
let einj e1 i e_name typs mark =
Bindlib.box_apply (fun e1 -> EInj (e1, i, e_name, typs), mark) e1
let ematch arg arms e_name mark =
Bindlib.box_apply2
(fun arg arms -> EMatch (arg, arms, e_name), pos)
(fun arg arms -> EMatch (arg, arms, e_name), mark)
arg (Bindlib.box_list arms)
let earray (args : expr Pos.marked Bindlib.box list) (pos : Pos.t) :
expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun args -> EArray args, pos) (Bindlib.box_list args)
let earray args mark =
Bindlib.box_apply (fun args -> EArray args, mark) (Bindlib.box_list args)
let elit (l : lit) (pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box (ELit l, pos)
let elit l mark = Bindlib.box (ELit l, mark)
let eabs
(binder : (expr, expr Pos.marked) Bindlib.mbinder Bindlib.box)
(pos_binder : Pos.t)
(typs : Dcalc.Ast.typ Pos.marked list)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply
(fun binder -> EAbs ((binder, pos_binder), typs), pos)
binder
let eabs binder typs mark =
Bindlib.box_apply (fun binder -> EAbs (binder, typs), mark) binder
let eapp
(e1 : expr Pos.marked Bindlib.box)
(args : expr Pos.marked Bindlib.box list)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
let eapp e1 args mark =
Bindlib.box_apply2
(fun e1 args -> EApp (e1, args), pos)
(fun e1 args -> EApp (e1, args), mark)
e1 (Bindlib.box_list args)
let eassert (e1 : expr Pos.marked Bindlib.box) (pos : Pos.t) :
expr Pos.marked Bindlib.box =
Bindlib.box_apply (fun e1 -> EAssert e1, pos) e1
let eassert e1 mark = Bindlib.box_apply (fun e1 -> EAssert e1, mark) e1
let eop op mark = Bindlib.box (EOp op, mark)
let eop (op : Dcalc.Ast.operator) (pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box (EOp op, pos)
let eraise (e1 : except) (pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box (ERaise e1, pos)
let ecatch
(e1 : expr Pos.marked Bindlib.box)
(exn : except)
(e2 : expr Pos.marked Bindlib.box)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply2 (fun e1 e2 -> ECatch (e1, exn, e2), pos) e1 e2
let eifthenelse
(e1 : expr Pos.marked Bindlib.box)
(e2 : expr Pos.marked Bindlib.box)
(e3 : expr Pos.marked Bindlib.box)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
let eifthenelse e1 e2 e3 pos =
Bindlib.box_apply3 (fun e1 e2 e3 -> EIfThenElse (e1, e2, e3), pos) e1 e2 e3
type 'm var = 'm expr Bindlib.var
type 'm vars = 'm expr Bindlib.mvar
let new_var s = Bindlib.new_var (fun x -> EVar x) s
module Var = struct
type t = expr Bindlib.var
type t = V : 'a var -> t
(* See Dcalc.Ast.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
let t v = V v
let get (V v) = Bindlib.copy_var v (fun x -> EVar x) (Bindlib.name_of v)
let compare (V x) (V y) = Bindlib.compare_vars x y
end
module VarMap = Map.Make (Var)
module VarSet = Set.Make (Var)
module VarMap = Map.Make (Var)
type vars = expr Bindlib.mvar
(* </copy-paste> *)
let map_expr
(ctx : 'a)
~(f : 'a -> expr Pos.marked -> expr Pos.marked Bindlib.box)
(e : expr Pos.marked) : expr Pos.marked Bindlib.box =
match Pos.unmark e with
| EVar (v, _pos) -> evar v (Pos.get_position e)
let eraise e1 pos = Bindlib.box (ERaise e1, pos)
let ecatch e1 exn e2 pos =
Bindlib.box_apply2 (fun e1 e2 -> ECatch (e1, exn, e2), pos) e1 e2
let translate_var v = Bindlib.copy_var v (fun x -> EVar x) (Bindlib.name_of v)
let map_expr ctx ~f e =
let m = Marked.get_mark e in
match Marked.unmark e with
| EVar v -> evar (translate_var v) (Marked.get_mark e)
| EApp (e1, args) ->
eapp (f ctx e1) (List.map (f ctx) args) (Pos.get_position e)
| EAbs ((binder, binder_pos), typs) ->
eabs
(Bindlib.box_mbinder (f ctx) binder)
binder_pos typs (Pos.get_position e)
| ETuple (args, s) -> etuple (List.map (f ctx) args) s (Pos.get_position e)
eapp (f ctx e1) (List.map (f ctx) args) (Marked.get_mark e)
| EAbs (binder, typs) ->
let vars, body = Bindlib.unmbind binder in
eabs (Bindlib.bind_mvar (Array.map translate_var vars) (f ctx body)) typs m
| ETuple (args, s) -> etuple (List.map (f ctx) args) s (Marked.get_mark e)
| ETupleAccess (e1, n, s_name, typs) ->
etupleaccess ((f ctx) e1) n s_name typs (Pos.get_position e)
etupleaccess ((f ctx) e1) n s_name typs (Marked.get_mark e)
| EInj (e1, i, e_name, typs) ->
einj ((f ctx) e1) i e_name typs (Pos.get_position e)
einj ((f ctx) e1) i e_name typs (Marked.get_mark e)
| EMatch (arg, arms, e_name) ->
ematch ((f ctx) arg) (List.map (f ctx) arms) e_name (Pos.get_position e)
| EArray args -> earray (List.map (f ctx) args) (Pos.get_position e)
| ELit l -> elit l (Pos.get_position e)
| EAssert e1 -> eassert ((f ctx) e1) (Pos.get_position e)
| EOp op -> Bindlib.box (EOp op, Pos.get_position e)
| ERaise exn -> eraise exn (Pos.get_position e)
ematch ((f ctx) arg) (List.map (f ctx) arms) e_name (Marked.get_mark e)
| EArray args -> earray (List.map (f ctx) args) (Marked.get_mark e)
| ELit l -> elit l (Marked.get_mark e)
| EAssert e1 -> eassert ((f ctx) e1) (Marked.get_mark e)
| EOp op -> Bindlib.box (EOp op, Marked.get_mark e)
| ERaise exn -> eraise exn (Marked.get_mark e)
| EIfThenElse (e1, e2, e3) ->
eifthenelse ((f ctx) e1) ((f ctx) e2) ((f ctx) e3) (Pos.get_position e)
| ECatch (e1, exn, e2) ->
ecatch (f ctx e1) exn (f ctx e2) (Pos.get_position e)
eifthenelse ((f ctx) e1) ((f ctx) e2) ((f ctx) e3) (Marked.get_mark e)
| ECatch (e1, exn, e2) -> ecatch (f ctx e1) exn (f ctx e2) (Marked.get_mark e)
let rec map_expr_top_down ~f e =
map_expr () ~f:(fun () -> map_expr_top_down ~f) (f e)
let map_expr_marks ~f e =
map_expr_top_down ~f:(fun e -> Marked.(mark (f (get_mark e)) (unmark e))) e
let untype_expr e =
map_expr_marks ~f:(fun m -> Untyped { pos = D.mark_pos m }) e
let untype_program prg =
{
prg with
D.scopes =
Bindlib.unbox
(D.map_exprs_in_scopes
~f:(fun e -> untype_expr e)
~varf:translate_var prg.D.scopes);
}
(** See [Bindlib.box_term] documentation for why we are doing that. *)
let box_expr (e : expr Pos.marked) : expr Pos.marked Bindlib.box =
let box_expr (e : 'm marked_expr) : 'm marked_expr Bindlib.box =
let rec id_t () e = map_expr () ~f:id_t e in
id_t () e
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_var (x, mark) =
Bindlib.box_apply (fun x -> x, mark) (Bindlib.box_var x)
let make_abs
(xs : vars)
(e : expr Pos.marked Bindlib.box)
(pos_binder : Pos.t)
(taus : D.typ Pos.marked list)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
Bindlib.box_apply
(fun b -> EAbs ((b, pos_binder), taus), pos)
(Bindlib.bind_mvar xs e)
let make_abs xs e taus mark =
Bindlib.box_apply (fun b -> EAbs (b, taus), mark) (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_app e u mark =
Bindlib.box_apply2 (fun e u -> EApp (e, u), mark) e (Bindlib.box_list u)
let make_let_in
(x : Var.t)
(tau : D.typ Pos.marked)
(e1 : expr Pos.marked Bindlib.box)
(e2 : expr Pos.marked Bindlib.box)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
make_app (make_abs (Array.of_list [x]) e2 pos [tau] pos) [e1] pos
let make_let_in x tau e1 e2 pos =
let m_e1 = Marked.get_mark (Bindlib.unbox e1) in
let m_e2 = Marked.get_mark (Bindlib.unbox e2) in
let m_abs =
D.map_mark2
(fun _ _ -> pos)
(fun m1 m2 -> TArrow (m1.ty, m2.ty), m1.pos)
m_e1 m_e2
in
make_app (make_abs [| x |] e2 [tau] m_abs) [e1] m_e2
let make_multiple_let_in
(xs : Var.t array)
(taus : D.typ Pos.marked list)
(e1 : expr Pos.marked Bindlib.box list)
(e2 : expr Pos.marked Bindlib.box)
(pos : Pos.t) : expr Pos.marked Bindlib.box =
make_app (make_abs xs e2 pos taus pos) e1 pos
let make_multiple_let_in xs taus e1s e2 pos =
(* let m_e1s = List.map (fun e -> Marked.get_mark (Bindlib.unbox e)) e1s in *)
let m_e1s =
D.fold_marks List.hd
(fun tys ->
D.TTuple (List.map (fun t -> t.D.ty) tys, None), (List.hd tys).D.pos)
(List.map (fun e -> Marked.get_mark (Bindlib.unbox e)) e1s)
in
let m_e2 = Marked.get_mark (Bindlib.unbox e2) in
let m_abs =
D.map_mark2
(fun _ _ -> pos)
(fun m1 m2 -> Marked.mark pos (D.TArrow (m1.ty, m2.ty)))
m_e1s m_e2
in
make_app (make_abs xs e2 taus m_abs) e1s m_e2
let ( let+ ) x f = Bindlib.box_apply f x
let ( and+ ) x y = Bindlib.box_pair x y
@ -229,57 +214,53 @@ let none_constr : D.EnumConstructor.t =
let some_constr : D.EnumConstructor.t =
D.EnumConstructor.fresh ("ESome", Pos.no_pos)
let option_enum_config : (D.EnumConstructor.t * D.typ Pos.marked) list =
let option_enum_config : (D.EnumConstructor.t * D.typ Marked.pos) list =
[none_constr, (D.TLit D.TUnit, Pos.no_pos); some_constr, (D.TAny, Pos.no_pos)]
let make_none (pos : Pos.t) : expr Pos.marked Bindlib.box =
let mark : 'a -> 'a Pos.marked = Pos.mark pos in
Bindlib.box @@ mark
@@ EInj
(mark @@ ELit LUnit, 0, option_enum, [D.TLit D.TUnit, pos; D.TAny, pos])
(* FIXME: proper typing in all the constructors below *)
let make_some (e : expr Pos.marked Bindlib.box) : expr Pos.marked Bindlib.box =
let pos = Pos.get_position @@ Bindlib.unbox e in
let mark : 'a -> 'a Pos.marked = Pos.mark pos in
begin[@ocamlformat "disable"]
let+ e = e in
mark @@ EInj (e, 1, option_enum, [ (D.TLit D.TUnit, pos); (D.TAny, pos) ])
end
let make_none m =
let mark = Marked.mark m in
let tunit = D.TLit D.TUnit, D.mark_pos m in
Bindlib.box
@@ mark
@@ EInj
( Marked.mark
(D.map_mark (fun pos -> pos) (fun _ -> tunit) m)
(ELit LUnit),
0,
option_enum,
[D.TLit D.TUnit, Pos.no_pos; D.TAny, Pos.no_pos] )
let make_some e =
let m = Marked.get_mark @@ Bindlib.unbox e in
let mark = Marked.mark m in
let+ e in
mark
@@ EInj
(e, 1, option_enum, [D.TLit D.TUnit, D.mark_pos m; D.TAny, D.mark_pos m])
(** [make_matchopt_with_abs_arms arg e_none e_some] build an expression
[match arg with |None -> e_none | Some -> e_some] and requires e_some and
e_none to be in the form [EAbs ...].*)
let make_matchopt_with_abs_arms
(arg : expr Pos.marked Bindlib.box)
(e_none : expr Pos.marked Bindlib.box)
(e_some : expr Pos.marked Bindlib.box) : expr Pos.marked Bindlib.box =
let pos = Pos.get_position @@ Bindlib.unbox arg in
let mark : 'a -> 'a Pos.marked = Pos.mark pos in
begin[@ocamlformat "disable"]
let+ arg = arg
and+ e_none = e_none
and+ e_some = e_some in
mark @@ EMatch (arg, [ e_none; e_some ], option_enum)
end
let make_matchopt_with_abs_arms arg e_none e_some =
let m = Marked.get_mark @@ Bindlib.unbox arg in
let mark = Marked.mark m in
let+ arg and+ e_none and+ e_some in
mark @@ EMatch (arg, [e_none; e_some], option_enum)
(** [make_matchopt pos v tau arg e_none e_some] builds an expression
[match arg with | None () -> e_none | Some v -> e_some]. It binds v to
e_some, permitting it to be used inside the expression. There is no
requirements on the form of both e_some and e_none. *)
let make_matchopt
(pos : Pos.t)
(v : Var.t)
(tau : D.typ Pos.marked)
(arg : expr Pos.marked Bindlib.box)
(e_none : expr Pos.marked Bindlib.box)
(e_some : expr Pos.marked Bindlib.box) : expr Pos.marked Bindlib.box =
let x = Var.make ("_", pos) in
let make_matchopt m v tau arg e_none e_some =
let x = new_var "_" in
make_matchopt_with_abs_arms arg
(make_abs (Array.of_list [x]) e_none pos [D.TLit D.TUnit, pos] pos)
(make_abs (Array.of_list [v]) e_some pos [tau] pos)
(make_abs (Array.of_list [x]) e_none [D.TLit D.TUnit, D.mark_pos m] m)
(make_abs (Array.of_list [v]) e_some [tau] m)
let handle_default = Var.make ("handle_default", Pos.no_pos)
let handle_default_opt = Var.make ("handle_default_opt", Pos.no_pos)
let handle_default = Var.t (new_var "handle_default")
let handle_default_opt = Var.t (new_var "handle_default_opt")
type binder = (expr, expr Pos.marked) Bindlib.binder
type 'm binder = ('m expr, 'm marked_expr) Bindlib.binder

224
compiler/lcalc/ast.mli
View File

@ -15,6 +15,7 @@
the License. *)
open Utils
module Runtime = Runtime_ocaml.Runtime
(** Abstract syntax tree for the lambda calculus *)
@ -33,190 +34,217 @@ type lit =
| LDuration of Runtime.duration
type except = ConflictError | EmptyError | NoValueProvided | Crash
type 'm mark = 'm Dcalc.Ast.mark
type expr =
| EVar of expr Bindlib.var Pos.marked
| ETuple of expr Pos.marked list * Dcalc.Ast.StructName.t option
type 'm marked_expr = ('m expr, 'm) Dcalc.Ast.marked
and 'm expr =
| EVar of 'm expr Bindlib.var
| ETuple of 'm marked_expr list * Dcalc.Ast.StructName.t option
(** The [MarkedString.info] is the former struct field name*)
| ETupleAccess of
expr Pos.marked
'm marked_expr
* int
* Dcalc.Ast.StructName.t option
* Dcalc.Ast.typ Pos.marked list
* Dcalc.Ast.typ Marked.pos list
(** The [MarkedString.info] is the former struct field name *)
| EInj of
expr Pos.marked
'm marked_expr
* int
* Dcalc.Ast.EnumName.t
* Dcalc.Ast.typ Pos.marked list
* Dcalc.Ast.typ Marked.pos list
(** The [MarkedString.info] is the former enum case name *)
| EMatch of expr Pos.marked * expr Pos.marked list * Dcalc.Ast.EnumName.t
| EMatch of 'm marked_expr * 'm marked_expr list * Dcalc.Ast.EnumName.t
(** The [MarkedString.info] is the former enum case name *)
| EArray of expr Pos.marked list
| EArray of 'm marked_expr list
| ELit of lit
| EAbs of
(expr, expr Pos.marked) Bindlib.mbinder Pos.marked
* Dcalc.Ast.typ Pos.marked list
| EApp of expr Pos.marked * expr Pos.marked list
| EAssert of expr Pos.marked
('m expr, 'm marked_expr) Bindlib.mbinder * Dcalc.Ast.typ Marked.pos list
| EApp of 'm marked_expr * 'm marked_expr list
| EAssert of 'm marked_expr
| EOp of Dcalc.Ast.operator
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
| EIfThenElse of 'm marked_expr * 'm marked_expr * 'm marked_expr
| ERaise of except
| ECatch of expr Pos.marked * except * expr Pos.marked
| ECatch of 'm marked_expr * except * 'm marked_expr
type program = { decl_ctx : Dcalc.Ast.decl_ctx; scopes : expr Dcalc.Ast.scopes }
type 'm program = ('m expr, 'm) Dcalc.Ast.program_generic
(** {1 Variable helpers} *)
module Var : sig
type t = expr Bindlib.var
type 'm var = 'm expr Bindlib.var
type 'm vars = 'm expr Bindlib.mvar
val make : string Pos.marked -> t
module Var : sig
type t
val t : 'm expr Bindlib.var -> t
val get : t -> 'm expr Bindlib.var
val compare : t -> t -> int
end
module VarMap : Map.S with type key = Var.t
module VarSet : Set.S with type elt = Var.t
type vars = expr Bindlib.mvar
type binder = (expr, expr Pos.marked) Bindlib.binder
val new_var : string -> 'm var
(** {1 Boxed constructors}*)
type 'm binder = ('m expr, 'm marked_expr) Bindlib.binder
val evar : expr Bindlib.var -> Pos.t -> expr Pos.marked Bindlib.box
(** {2 Program traversal} *)
val map_expr :
'a ->
f:('a -> 'm1 marked_expr -> 'm2 marked_expr Bindlib.box) ->
('m1 expr, 'm2 mark) Marked.t ->
'm2 marked_expr Bindlib.box
(** See [Dcalc.Ast.map_expr] *)
val map_expr_top_down :
f:('m1 marked_expr -> ('m1 expr, 'm2 mark) Marked.t) ->
'm1 marked_expr ->
'm2 marked_expr Bindlib.box
(** See [Dcalc.Ast.map_expr_top_down] *)
val map_expr_marks :
f:('m1 mark -> 'm2 mark) -> 'm1 marked_expr -> 'm2 marked_expr Bindlib.box
(** See [Dcalc.Ast.map_expr_marks] *)
val untype_expr : 'm marked_expr -> Dcalc.Ast.untyped marked_expr Bindlib.box
val untype_program : 'm program -> Dcalc.Ast.untyped program
(** {1 Boxed constructors} *)
val evar : 'm expr Bindlib.var -> 'm mark -> 'm marked_expr Bindlib.box
val etuple :
expr Pos.marked Bindlib.box list ->
'm marked_expr Bindlib.box list ->
Dcalc.Ast.StructName.t option ->
Pos.t ->
expr Pos.marked Bindlib.box
'm mark ->
'm marked_expr Bindlib.box
val etupleaccess :
expr Pos.marked Bindlib.box ->
'm marked_expr Bindlib.box ->
int ->
Dcalc.Ast.StructName.t option ->
Dcalc.Ast.typ Pos.marked list ->
Pos.t ->
expr Pos.marked Bindlib.box
Dcalc.Ast.typ Marked.pos list ->
'm mark ->
'm marked_expr Bindlib.box
val einj :
expr Pos.marked Bindlib.box ->
'm marked_expr Bindlib.box ->
int ->
Dcalc.Ast.EnumName.t ->
Dcalc.Ast.typ Pos.marked list ->
Pos.t ->
expr Pos.marked Bindlib.box
Dcalc.Ast.typ Marked.pos list ->
'm mark ->
'm marked_expr Bindlib.box
val ematch :
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box list ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
Dcalc.Ast.EnumName.t ->
Pos.t ->
expr Pos.marked Bindlib.box
'm mark ->
'm marked_expr Bindlib.box
val earray :
expr Pos.marked Bindlib.box list -> Pos.t -> expr Pos.marked Bindlib.box
'm marked_expr Bindlib.box list -> 'm mark -> 'm marked_expr Bindlib.box
val elit : lit -> Pos.t -> expr Pos.marked Bindlib.box
val elit : lit -> 'm mark -> 'm marked_expr Bindlib.box
val eabs :
(expr, expr Pos.marked) Bindlib.mbinder Bindlib.box ->
Pos.t ->
Dcalc.Ast.typ Pos.marked list ->
Pos.t ->
expr Pos.marked Bindlib.box
('m expr, 'm marked_expr) Bindlib.mbinder Bindlib.box ->
Dcalc.Ast.typ Marked.pos list ->
'm mark ->
'm marked_expr Bindlib.box
val eapp :
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box list ->
Pos.t ->
expr Pos.marked Bindlib.box
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
'm mark ->
'm marked_expr Bindlib.box
val eassert :
expr Pos.marked Bindlib.box -> Pos.t -> expr Pos.marked Bindlib.box
'm marked_expr Bindlib.box -> 'm mark -> 'm marked_expr Bindlib.box
val eop : Dcalc.Ast.operator -> Pos.t -> expr Pos.marked Bindlib.box
val eop : Dcalc.Ast.operator -> 'm mark -> 'm marked_expr Bindlib.box
val eifthenelse :
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box ->
Pos.t ->
expr Pos.marked Bindlib.box
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm mark ->
'm marked_expr Bindlib.box
val ecatch :
expr Pos.marked Bindlib.box ->
'm marked_expr Bindlib.box ->
except ->
expr Pos.marked Bindlib.box ->
Pos.t ->
expr Pos.marked Bindlib.box
'm marked_expr Bindlib.box ->
'm mark ->
'm marked_expr Bindlib.box
val eraise : except -> Pos.t -> expr Pos.marked Bindlib.box
val eraise : except -> 'm mark -> 'm marked_expr Bindlib.box
(** {1 Language terms construction}*)
val make_var : Var.t Pos.marked -> expr Pos.marked Bindlib.box
val make_var : ('m var, 'm) Dcalc.Ast.marked -> 'm marked_expr Bindlib.box
val make_abs :
vars ->
expr Pos.marked Bindlib.box ->
Pos.t ->
Dcalc.Ast.typ Pos.marked list ->
Pos.t ->
expr Pos.marked Bindlib.box
'm vars ->
'm marked_expr Bindlib.box ->
Dcalc.Ast.typ Marked.pos list ->
'm mark ->
'm marked_expr Bindlib.box
val make_app :
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box list ->
Pos.t ->
expr Pos.marked Bindlib.box
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box list ->
'm mark ->
'm marked_expr Bindlib.box
val make_let_in :
Var.t ->
Dcalc.Ast.typ Pos.marked ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box ->
'm var ->
Dcalc.Ast.typ Marked.pos ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
Pos.t ->
expr Pos.marked Bindlib.box
'm marked_expr Bindlib.box
val make_multiple_let_in :
Var.t array ->
Dcalc.Ast.typ Pos.marked list ->
expr Pos.marked Bindlib.box list ->
expr Pos.marked Bindlib.box ->
'm vars ->
Dcalc.Ast.typ Marked.pos list ->
'm marked_expr Bindlib.box list ->
'm marked_expr Bindlib.box ->
Pos.t ->
expr Pos.marked Bindlib.box
'm marked_expr Bindlib.box
val option_enum : Dcalc.Ast.EnumName.t
val none_constr : Dcalc.Ast.EnumConstructor.t
val some_constr : Dcalc.Ast.EnumConstructor.t
val option_enum_config :
(Dcalc.Ast.EnumConstructor.t * Dcalc.Ast.typ Pos.marked) list
(Dcalc.Ast.EnumConstructor.t * Dcalc.Ast.typ Marked.pos) list
val make_none : Pos.t -> expr Pos.marked Bindlib.box
val make_some : expr Pos.marked Bindlib.box -> expr Pos.marked Bindlib.box
val make_none : 'm mark -> 'm marked_expr Bindlib.box
val make_some : 'm marked_expr Bindlib.box -> 'm marked_expr Bindlib.box
val make_matchopt_with_abs_arms :
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box
val make_matchopt :
Pos.t ->
Var.t ->
Dcalc.Ast.typ Pos.marked ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box
'm mark ->
'm var ->
Dcalc.Ast.typ Marked.pos ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box ->
'm marked_expr Bindlib.box
(** [e' = make_matchopt'' pos v e e_none e_some] Builds the term corresponding
to [match e with | None -> fun () -> e_none |Some -> fun v -> e_some]. *)
val box_expr : expr Pos.marked -> expr Pos.marked Bindlib.box
val box_expr : 'm marked_expr -> 'm marked_expr Bindlib.box
(** {1 Special symbols}*)
(** {1 Special symbols} *)
val handle_default : Var.t
val handle_default_opt : Var.t

81
compiler/lcalc/backends.ml
View File

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

504
compiler/lcalc/closure_conversion.ml
View File

@ -21,275 +21,283 @@ module D = Dcalc.Ast
(** TODO: This version is not yet debugged and ought to be specialized when
Lcalc has more structure. *)
type closure = { name : Var.t; expr : expr Pos.marked Bindlib.box }
type ctx = { name_context : string; globally_bound_vars : VarSet.t }
(** Returns the expression with closed closures and the set of free variables
inside this new expression. Implementation guided by
http://gallium.inria.fr/~fpottier/mpri/cours04.pdf#page=9. *)
let rec closure_conversion_expr (ctx : ctx) (e : expr Pos.marked) :
expr Pos.marked Bindlib.box * VarSet.t =
match Pos.unmark e with
| EVar v ->
( Bindlib.box_apply
(fun new_v -> new_v, Pos.get_position v)
(Bindlib.box_var (Pos.unmark v)),
VarSet.diff (VarSet.singleton (Pos.unmark v)) ctx.globally_bound_vars )
| ETuple (args, s) ->
let new_args, free_vars =
List.fold_left
(fun (new_args, free_vars) arg ->
let new_arg, new_free_vars = closure_conversion_expr ctx arg in
new_arg :: new_args, VarSet.union new_free_vars free_vars)
([], VarSet.empty) args
in
( Bindlib.box_apply
(fun new_args -> ETuple (List.rev new_args, s), Pos.get_position e)
(Bindlib.box_list new_args),
free_vars )
| ETupleAccess (e1, n, s, typs) ->
let new_e1, free_vars = closure_conversion_expr ctx e1 in
( Bindlib.box_apply
(fun new_e1 -> ETupleAccess (new_e1, n, s, typs), Pos.get_position e)
new_e1,
free_vars )
| EInj (e1, n, e_name, typs) ->
let new_e1, free_vars = closure_conversion_expr ctx e1 in
( Bindlib.box_apply
(fun new_e1 -> EInj (new_e1, n, e_name, typs), Pos.get_position e)
new_e1,
free_vars )
| EMatch (e1, arms, e_name) ->
let new_e1, free_vars = closure_conversion_expr ctx e1 in
(* We do not close the clotures inside the arms of the match expression,
since they get a special treatment at compilation to Scalc. *)
let new_arms, free_vars =
List.fold_right
(fun arm (new_arms, free_vars) ->
match Pos.unmark arm with
| EAbs ((binder, binder_pos), typs) ->
let vars, body = Bindlib.unmbind binder in
let new_body, new_free_vars = closure_conversion_expr ctx body in
let new_binder = Bindlib.bind_mvar vars new_body in
( Bindlib.box_apply
(fun new_binder ->
EAbs ((new_binder, binder_pos), typs), Pos.get_position arm)
new_binder
:: new_arms,
VarSet.union free_vars new_free_vars )
| _ -> failwith "should not happen")
arms ([], free_vars)
in
( Bindlib.box_apply2
(fun new_e1 new_arms ->
EMatch (new_e1, new_arms, e_name), Pos.get_position e)
new_e1
(Bindlib.box_list new_arms),
free_vars )
| EArray args ->
let new_args, free_vars =
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = closure_conversion_expr ctx arg in
new_arg :: new_args, VarSet.union free_vars new_free_vars)
args ([], VarSet.empty)
in
( Bindlib.box_apply
(fun new_args -> EArray new_args, Pos.get_position e)
(Bindlib.box_list new_args),
free_vars )
| ELit l -> Bindlib.box (ELit l, Pos.get_position e), VarSet.empty
| EApp ((EAbs ((binder, binder_pos), typs_abs), e1_pos), args) ->
(* let-binding, we should not close these *)
let vars, body = Bindlib.unmbind binder in
let new_body, free_vars = closure_conversion_expr ctx body in
let new_binder = Bindlib.bind_mvar vars new_body in
let new_args, free_vars =
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = closure_conversion_expr ctx arg in
new_arg :: new_args, VarSet.union free_vars new_free_vars)
args ([], free_vars)
in
( Bindlib.box_apply2
(fun new_binder new_args ->
( EApp ((EAbs ((new_binder, binder_pos), typs_abs), e1_pos), new_args),
Pos.get_position e ))
new_binder
(Bindlib.box_list new_args),
free_vars )
| EAbs ((binder, binder_pos), typs) ->
(* λ x.t *)
(* Converting the closure. *)
let vars, body = Bindlib.unmbind binder in
(* t *)
let new_body, body_vars = closure_conversion_expr ctx body in
(* [[t]] *)
let extra_vars =
VarSet.diff body_vars (VarSet.of_list (Array.to_list vars))
in
let extra_vars_list = VarSet.elements extra_vars in
(* x1, ..., xn *)
let code_var = Var.make (ctx.name_context, binder_pos) in
(* code *)
let inner_c_var = Var.make ("env", binder_pos) in
let new_closure_body =
make_multiple_let_in
(Array.of_list extra_vars_list)
(List.init (List.length extra_vars_list) (fun _ ->
Dcalc.Ast.TAny, binder_pos))
(List.mapi
(fun i _ ->
Bindlib.box_apply
(fun inner_c_var ->
( ETupleAccess
( (inner_c_var, binder_pos),
i + 1,
None,
List.init
(List.length extra_vars_list + 1)
(fun _ -> Dcalc.Ast.TAny, binder_pos) ),
binder_pos ))
(Bindlib.box_var inner_c_var))
extra_vars_list)
new_body binder_pos
in
let new_closure =
make_abs
(Array.concat [Array.make 1 inner_c_var; vars])
new_closure_body binder_pos
((Dcalc.Ast.TAny, binder_pos) :: typs)
(Pos.get_position e)
in
( make_let_in code_var
(Dcalc.Ast.TAny, Pos.get_position e)
new_closure
(Bindlib.box_apply2
(fun code_var extra_vars ->
( ETuple
( (code_var, binder_pos)
:: List.map
(fun extra_var -> extra_var, binder_pos)
extra_vars,
None ),
Pos.get_position e ))
(Bindlib.box_var code_var)
(Bindlib.box_list
(List.map
(fun extra_var -> Bindlib.box_var extra_var)
extra_vars_list)))
(Pos.get_position e),
extra_vars )
| EApp ((EOp op, pos_op), args) ->
(* This corresponds to an operator call, which we don't want to transform*)
let new_args, free_vars =
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = closure_conversion_expr ctx arg in
new_arg :: new_args, VarSet.union free_vars new_free_vars)
args ([], VarSet.empty)
in
( Bindlib.box_apply
(fun new_e2 -> EApp ((EOp op, pos_op), new_e2), Pos.get_position e)
(Bindlib.box_list new_args),
free_vars )
| EApp ((EVar (v, _), v_pos), args) when VarSet.mem v ctx.globally_bound_vars
->
(* This corresponds to a scope call, which we don't want to transform*)
let new_args, free_vars =
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = closure_conversion_expr ctx arg in
new_arg :: new_args, VarSet.union free_vars new_free_vars)
args ([], VarSet.empty)
in
( Bindlib.box_apply2
(fun new_v new_e2 -> EApp ((new_v, v_pos), new_e2), Pos.get_position e)
(Bindlib.box_var v)
(Bindlib.box_list new_args),
free_vars )
| EApp (e1, args) ->
let new_e1, free_vars = closure_conversion_expr ctx e1 in
let env_var = Var.make ("env", Pos.get_position e1) in
let code_var = Var.make ("code", Pos.get_position e1) in
let new_args, free_vars =
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = closure_conversion_expr ctx arg in
new_arg :: new_args, VarSet.union free_vars new_free_vars)
args ([], free_vars)
in
let call_expr =
make_let_in code_var
(Dcalc.Ast.TAny, Pos.get_position e)
(Bindlib.box_apply
(fun env_var ->
( ETupleAccess
((env_var, Pos.get_position e1), 0, None, [ (*TODO: fill?*) ]),
Pos.get_position e ))
(Bindlib.box_var env_var))
(Bindlib.box_apply3
(fun code_var env_var new_args ->
( EApp
( (code_var, Pos.get_position e1),
(env_var, Pos.get_position e1) :: new_args ),
Pos.get_position e ))
(Bindlib.box_var code_var) (Bindlib.box_var env_var)
(Bindlib.box_list new_args))
(Pos.get_position e)
in
( make_let_in env_var
(Dcalc.Ast.TAny, Pos.get_position e)
new_e1 call_expr (Pos.get_position e),
free_vars )
| EAssert e1 ->
let new_e1, free_vars = closure_conversion_expr ctx e1 in
( Bindlib.box_apply (fun new_e1 -> EAssert new_e1, Pos.get_position e) new_e1,
free_vars )
| EOp op -> Bindlib.box (EOp op, Pos.get_position e), VarSet.empty
| EIfThenElse (e1, e2, e3) ->
let new_e1, free_vars1 = closure_conversion_expr ctx e1 in
let new_e2, free_vars2 = closure_conversion_expr ctx e2 in
let new_e3, free_vars3 = closure_conversion_expr ctx e3 in
( Bindlib.box_apply3
(fun new_e1 new_e2 new_e3 ->
EIfThenElse (new_e1, new_e2, new_e3), Pos.get_position e)
new_e1 new_e2 new_e3,
VarSet.union (VarSet.union free_vars1 free_vars2) free_vars3 )
| ERaise except ->
Bindlib.box (ERaise except, Pos.get_position e), VarSet.empty
| ECatch (e1, except, e2) ->
let new_e1, free_vars1 = closure_conversion_expr ctx e1 in
let new_e2, free_vars2 = closure_conversion_expr ctx e2 in
( Bindlib.box_apply2
(fun new_e1 new_e2 ->
ECatch (new_e1, except, new_e2), Pos.get_position e)
new_e1 new_e2,
VarSet.union free_vars1 free_vars2 )
let closure_conversion_expr (type m) (ctx : ctx) (e : m marked_expr) :
m marked_expr Bindlib.box =
let module MVarSet = Set.Make (struct
type t = m var
let closure_conversion (p : program) : program Bindlib.box =
let compare = Bindlib.compare_vars
end) in
let rec aux e =
match Marked.unmark e with
| EVar v ->
( Bindlib.box_apply
(fun new_v -> new_v, Marked.get_mark e)
(Bindlib.box_var v),
if VarSet.mem (Var.t v) ctx.globally_bound_vars then MVarSet.empty
else MVarSet.singleton v )
| ETuple (args, s) ->
let new_args, free_vars =
List.fold_left
(fun (new_args, free_vars) arg ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, MVarSet.union new_free_vars free_vars)
([], MVarSet.empty) args
in
( Bindlib.box_apply
(fun new_args -> ETuple (List.rev new_args, s), Marked.get_mark e)
(Bindlib.box_list new_args),
free_vars )
| ETupleAccess (e1, n, s, typs) ->
let new_e1, free_vars = aux e1 in
( Bindlib.box_apply
(fun new_e1 -> ETupleAccess (new_e1, n, s, typs), Marked.get_mark e)
new_e1,
free_vars )
| EInj (e1, n, e_name, typs) ->
let new_e1, free_vars = aux e1 in
( Bindlib.box_apply
(fun new_e1 -> EInj (new_e1, n, e_name, typs), Marked.get_mark e)
new_e1,
free_vars )
| EMatch (e1, arms, e_name) ->
let new_e1, free_vars = aux e1 in
(* We do not close the clotures inside the arms of the match expression,
since they get a special treatment at compilation to Scalc. *)
let new_arms, free_vars =
List.fold_right
(fun arm (new_arms, free_vars) ->
match Marked.unmark arm with
| EAbs (binder, typs) ->
let vars, body = Bindlib.unmbind binder in
let new_body, new_free_vars = aux body in
let new_binder = Bindlib.bind_mvar vars new_body in
( Bindlib.box_apply
(fun new_binder ->
EAbs (new_binder, typs), Marked.get_mark arm)
new_binder
:: new_arms,
MVarSet.union free_vars new_free_vars )
| _ -> failwith "should not happen")
arms ([], free_vars)
in
( Bindlib.box_apply2
(fun new_e1 new_arms ->
EMatch (new_e1, new_arms, e_name), Marked.get_mark e)
new_e1
(Bindlib.box_list new_arms),
free_vars )
| EArray args ->
let new_args, free_vars =
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, MVarSet.union free_vars new_free_vars)
args ([], MVarSet.empty)
in
( Bindlib.box_apply
(fun new_args -> EArray new_args, Marked.get_mark e)
(Bindlib.box_list new_args),
free_vars )
| ELit l -> Bindlib.box (ELit l, Marked.get_mark e), MVarSet.empty
| EApp ((EAbs (binder, typs_abs), e1_pos), args) ->
(* let-binding, we should not close these *)
let vars, body = Bindlib.unmbind binder in
let new_body, free_vars = aux body in
let new_binder = Bindlib.bind_mvar vars new_body in
let new_args, free_vars =
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, MVarSet.union free_vars new_free_vars)
args ([], free_vars)
in
( Bindlib.box_apply2
(fun new_binder new_args ->
( EApp ((EAbs (new_binder, typs_abs), e1_pos), new_args),
Marked.get_mark e ))
new_binder
(Bindlib.box_list new_args),
free_vars )
| EAbs (binder, typs) ->
(* λ x.t *)
let binder_mark = Marked.get_mark e in
let binder_pos = D.mark_pos binder_mark in
(* Converting the closure. *)
let vars, body = Bindlib.unmbind binder in
(* t *)
let new_body, body_vars = aux body in
(* [[t]] *)
let extra_vars =
MVarSet.diff body_vars (MVarSet.of_list (Array.to_list vars))
in
let extra_vars_list = MVarSet.elements extra_vars in
(* x1, ..., xn *)
let code_var = new_var ctx.name_context in
(* code *)
let inner_c_var = new_var "env" in
let any_ty = Dcalc.Ast.TAny, binder_pos in
let new_closure_body =
make_multiple_let_in
(Array.of_list extra_vars_list)
(List.map (fun _ -> any_ty) extra_vars_list)
(List.mapi
(fun i _ ->
Bindlib.box_apply
(fun inner_c_var ->
( ETupleAccess
( (inner_c_var, binder_mark),
i + 1,
None,
List.map (fun _ -> any_ty) extra_vars_list ),
binder_mark ))
(Bindlib.box_var inner_c_var))
extra_vars_list)
new_body (D.mark_pos binder_mark)
in
let new_closure =
make_abs
(Array.concat [Array.make 1 inner_c_var; vars])
new_closure_body
((Dcalc.Ast.TAny, binder_pos) :: typs)
(Marked.get_mark e)
in
( make_let_in code_var
(Dcalc.Ast.TAny, D.pos e)
new_closure
(Bindlib.box_apply2
(fun code_var extra_vars ->
( ETuple
( (code_var, binder_mark)
:: List.map
(fun extra_var -> extra_var, binder_mark)
extra_vars,
None ),
Marked.get_mark e ))
(Bindlib.box_var code_var)
(Bindlib.box_list
(List.map
(fun extra_var -> Bindlib.box_var extra_var)
extra_vars_list)))
(D.pos e),
extra_vars )
| EApp ((EOp op, pos_op), args) ->
(* This corresponds to an operator call, which we don't want to
transform*)
let new_args, free_vars =
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, MVarSet.union free_vars new_free_vars)
args ([], MVarSet.empty)
in
( Bindlib.box_apply
(fun new_e2 -> EApp ((EOp op, pos_op), new_e2), Marked.get_mark e)
(Bindlib.box_list new_args),
free_vars )
| EApp ((EVar v, v_pos), args)
when VarSet.mem (Var.t v) ctx.globally_bound_vars ->
(* This corresponds to a scope call, which we don't want to transform*)
let new_args, free_vars =
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, MVarSet.union free_vars new_free_vars)
args ([], MVarSet.empty)
in
( Bindlib.box_apply2
(fun new_v new_e2 -> EApp ((new_v, v_pos), new_e2), Marked.get_mark e)
(Bindlib.box_var v)
(Bindlib.box_list new_args),
free_vars )
| EApp (e1, args) ->
let new_e1, free_vars = aux e1 in
let env_var = new_var "env" in
let code_var = new_var "code" in
let new_args, free_vars =
List.fold_right
(fun arg (new_args, free_vars) ->
let new_arg, new_free_vars = aux arg in
new_arg :: new_args, MVarSet.union free_vars new_free_vars)
args ([], free_vars)
in
let call_expr =
make_let_in code_var
(Dcalc.Ast.TAny, D.pos e)
(Bindlib.box_apply
(fun env_var ->
( ETupleAccess
((env_var, Marked.get_mark e1), 0, None, [ (*TODO: fill?*) ]),
Marked.get_mark e ))
(Bindlib.box_var env_var))
(Bindlib.box_apply3
(fun code_var env_var new_args ->
( EApp
( (code_var, Marked.get_mark e1),
(env_var, Marked.get_mark e1) :: new_args ),
Marked.get_mark e ))
(Bindlib.box_var code_var) (Bindlib.box_var env_var)
(Bindlib.box_list new_args))
(D.pos e)
in
( make_let_in env_var (Dcalc.Ast.TAny, D.pos e) new_e1 call_expr (D.pos e),
free_vars )
| EAssert e1 ->
let new_e1, free_vars = aux e1 in
( Bindlib.box_apply
(fun new_e1 -> EAssert new_e1, Marked.get_mark e)
new_e1,
free_vars )
| EOp op -> Bindlib.box (EOp op, Marked.get_mark e), MVarSet.empty
| EIfThenElse (e1, e2, e3) ->
let new_e1, free_vars1 = aux e1 in
let new_e2, free_vars2 = aux e2 in
let new_e3, free_vars3 = aux e3 in
( Bindlib.box_apply3
(fun new_e1 new_e2 new_e3 ->
EIfThenElse (new_e1, new_e2, new_e3), Marked.get_mark e)
new_e1 new_e2 new_e3,
MVarSet.union (MVarSet.union free_vars1 free_vars2) free_vars3 )
| ERaise except ->
Bindlib.box (ERaise except, Marked.get_mark e), MVarSet.empty
| ECatch (e1, except, e2) ->
let new_e1, free_vars1 = aux e1 in
let new_e2, free_vars2 = aux e2 in
( Bindlib.box_apply2
(fun new_e1 new_e2 ->
ECatch (new_e1, except, new_e2), Marked.get_mark e)
new_e1 new_e2,
MVarSet.union free_vars1 free_vars2 )
in
let e', _vars = aux e in
e'
let closure_conversion (p : 'm program) : 'm program Bindlib.box =
let new_scopes, _ =
D.fold_left_scope_defs
~f:
(fun ((acc_new_scopes, global_vars) :
(expr D.scopes Bindlib.box -> expr D.scopes Bindlib.box)
* VarSet.t) (scope : expr D.scope_def) (scope_var : Var.t) ->
~f:(fun (acc_new_scopes, global_vars) scope scope_var ->
(* [acc_new_scopes] represents what has been translated in the past, it
needs a continuation to attach the rest of the translated scopes. *)
let scope_input_var, scope_body_expr =
Bindlib.unbind scope.scope_body.scope_body_expr
in
let global_vars = VarSet.add scope_var global_vars in
let global_vars = VarSet.add (Var.t scope_var) global_vars in
let ctx =
{
name_context =
Pos.unmark (Dcalc.Ast.ScopeName.get_info scope.scope_name);
Marked.unmark (Dcalc.Ast.ScopeName.get_info scope.scope_name);
globally_bound_vars = global_vars;
}
in
let new_scope_lets =
D.map_exprs_in_scope_lets
~f:(fun e -> fst (closure_conversion_expr ctx e))
~f:(closure_conversion_expr ctx)
~varf:(fun v -> v)
scope_body_expr
in
let new_scope_body_expr =

16
compiler/lcalc/backends.mli → compiler/lcalc/closure_conversion.mli
View File

@ -1,5 +1,5 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2021 Inria, contributor:
and social benefits computation rules. Copyright (C) 2022 Inria, contributor:
Denis Merigoux <denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
@ -14,14 +14,6 @@
License for the specific language governing permissions and limitations under
the License. *)
(** Helper functions common to all Catala compiler backends *)
val to_ascii : string -> string
(** Removes all non-ASCII diacritics from a string by converting them to their
base letter in the Latin alphabet *)
val to_lowercase : string -> string
(** Converts CamlCase into snake_case *)
val to_uppercase : string -> string
(** Convertes snake_case into CamlCase *)
val closure_conversion : 'm Ast.program -> 'm Ast.program Bindlib.box
(** Warning/todo: no effort was yet made to ensure correct propagation of type
annotations in the typed case *)

117
compiler/lcalc/compile_with_exceptions.ml
View File

@ -18,11 +18,11 @@ open Utils
module D = Dcalc.Ast
module A = Ast
type ctx = A.Var.t D.VarMap.t
type 'm ctx = 'm A.var D.VarMap.t
(** This environment contains a mapping between the variables in Dcalc and their
correspondance in Lcalc. *)
let translate_lit (l : D.lit) : A.expr =
let translate_lit (l : D.lit) : 'm A.expr =
match l with
| D.LBool l -> A.ELit (A.LBool l)
| D.LInt i -> A.ELit (A.LInt i)
@ -33,105 +33,104 @@ let translate_lit (l : D.lit) : A.expr =
| D.LDuration d -> A.ELit (A.LDuration d)
| D.LEmptyError -> A.ERaise A.EmptyError
let thunk_expr (e : A.expr Pos.marked Bindlib.box) (pos : Pos.t) :
A.expr Pos.marked Bindlib.box =
let dummy_var = A.Var.make ("_", pos) in
A.make_abs [| dummy_var |] e pos [D.TAny, pos] pos
let thunk_expr (e : 'm A.marked_expr Bindlib.box) (mark : 'm A.mark) :
'm A.marked_expr Bindlib.box =
let dummy_var = A.new_var "_" in
A.make_abs [| dummy_var |] e [D.TAny, D.mark_pos mark] mark
let rec translate_default
(ctx : ctx)
(exceptions : D.expr Pos.marked list)
(just : D.expr Pos.marked)
(cons : D.expr Pos.marked)
(pos_default : Pos.t) : A.expr Pos.marked Bindlib.box =
(ctx : 'm ctx)
(exceptions : 'm D.marked_expr list)
(just : 'm D.marked_expr)
(cons : 'm D.marked_expr)
(mark_default : 'm D.mark) : 'm A.marked_expr Bindlib.box =
let exceptions =
List.map
(fun except -> thunk_expr (translate_expr ctx except) pos_default)
(fun except -> thunk_expr (translate_expr ctx except) mark_default)
exceptions
in
let exceptions =
A.make_app
(A.make_var (A.handle_default, pos_default))
(A.make_var (A.Var.get A.handle_default, mark_default))
[
A.earray exceptions pos_default;
thunk_expr (translate_expr ctx just) pos_default;
thunk_expr (translate_expr ctx cons) pos_default;
A.earray exceptions mark_default;
thunk_expr (translate_expr ctx just) mark_default;
thunk_expr (translate_expr ctx cons) mark_default;
]
pos_default
mark_default
in
exceptions
and translate_expr (ctx : ctx) (e : D.expr Pos.marked) :
A.expr Pos.marked Bindlib.box =
match Pos.unmark e with
| D.EVar v -> A.make_var (D.VarMap.find (Pos.unmark v) ctx, Pos.get_position e)
and translate_expr (ctx : 'm ctx) (e : 'm D.marked_expr) :
'm A.marked_expr Bindlib.box =
match Marked.unmark e with
| D.EVar v -> A.make_var (D.VarMap.find (D.Var.t v) ctx, Marked.get_mark e)
| D.ETuple (args, s) ->
A.etuple (List.map (translate_expr ctx) args) s (Pos.get_position e)
A.etuple (List.map (translate_expr ctx) args) s (Marked.get_mark e)
| D.ETupleAccess (e1, i, s, ts) ->
A.etupleaccess (translate_expr ctx e1) i s ts (Pos.get_position e)
A.etupleaccess (translate_expr ctx e1) i s ts (Marked.get_mark e)
| D.EInj (e1, i, en, ts) ->
A.einj (translate_expr ctx e1) i en ts (Pos.get_position e)
A.einj (translate_expr ctx e1) i en ts (Marked.get_mark e)
| D.EMatch (e1, cases, en) ->
A.ematch (translate_expr ctx e1)
(List.map (translate_expr ctx) cases)
en (Pos.get_position e)
en (Marked.get_mark e)
| D.EArray es ->
A.earray (List.map (translate_expr ctx) es) (Pos.get_position e)
| D.ELit l -> Bindlib.box (Pos.same_pos_as (translate_lit l) e)
| D.EOp op -> A.eop op (Pos.get_position e)
A.earray (List.map (translate_expr ctx) es) (Marked.get_mark e)
| D.ELit l -> Bindlib.box (Marked.same_mark_as (translate_lit l) e)
| D.EOp op -> A.eop op (Marked.get_mark e)
| D.EIfThenElse (e1, e2, e3) ->
A.eifthenelse (translate_expr ctx e1) (translate_expr ctx e2)
(translate_expr ctx e3) (Pos.get_position e)
| D.EAssert e1 -> A.eassert (translate_expr ctx e1) (Pos.get_position e)
(translate_expr ctx e3) (Marked.get_mark e)
| D.EAssert e1 -> A.eassert (translate_expr ctx e1) (Marked.get_mark e)
| D.ErrorOnEmpty arg ->
A.ecatch (translate_expr ctx arg) A.EmptyError
(Bindlib.box (Pos.same_pos_as (A.ERaise A.NoValueProvided) e))
(Pos.get_position e)
(Bindlib.box (Marked.same_mark_as (A.ERaise A.NoValueProvided) e))
(Marked.get_mark e)
| D.EApp (e1, args) ->
A.eapp (translate_expr ctx e1)
(List.map (translate_expr ctx) args)
(Pos.get_position e)
| D.EAbs ((binder, pos_binder), ts) ->
(Marked.get_mark e)
| D.EAbs (binder, ts) ->
let vars, body = Bindlib.unmbind binder in
let ctx, lc_vars =
Array.fold_right
(fun var (ctx, lc_vars) ->
let lc_var = A.Var.make (Bindlib.name_of var, pos_binder) in
D.VarMap.add var lc_var ctx, lc_var :: lc_vars)
let lc_var = A.new_var (Bindlib.name_of var) in
D.VarMap.add (D.Var.t var) lc_var ctx, lc_var :: lc_vars)
vars (ctx, [])
in
let lc_vars = Array.of_list lc_vars in
let new_body = translate_expr ctx body in
let new_binder = Bindlib.bind_mvar lc_vars new_body in
Bindlib.box_apply
(fun new_binder ->
Pos.same_pos_as (A.EAbs ((new_binder, pos_binder), ts)) e)
(fun new_binder -> Marked.same_mark_as (A.EAbs (new_binder, ts)) e)
new_binder
| D.EDefault ([exn], just, cons) when !Cli.optimize_flag ->
A.ecatch (translate_expr ctx exn) A.EmptyError
(A.eifthenelse (translate_expr ctx just) (translate_expr ctx cons)
(Bindlib.box (Pos.same_pos_as (A.ERaise A.EmptyError) e))
(Pos.get_position e))
(Pos.get_position e)
(Bindlib.box (Marked.same_mark_as (A.ERaise A.EmptyError) e))
(Marked.get_mark e))
(Marked.get_mark e)
| D.EDefault (exceptions, just, cons) ->
translate_default ctx exceptions just cons (Pos.get_position e)
translate_default ctx exceptions just cons (Marked.get_mark e)
let rec translate_scope_lets
(decl_ctx : D.decl_ctx)
(ctx : A.Var.t D.VarMap.t)
(scope_lets : D.expr D.scope_body_expr) :
A.expr D.scope_body_expr Bindlib.box =
(ctx : 'm ctx)
(scope_lets : ('m D.expr, 'm) D.scope_body_expr) :
('m A.expr, 'm) D.scope_body_expr Bindlib.box =
match scope_lets with
| Result e -> Bindlib.box_apply (fun e -> D.Result e) (translate_expr ctx e)
| ScopeLet scope_let ->
let old_scope_let_var, scope_let_next =
Bindlib.unbind scope_let.scope_let_next
in
let new_scope_let_var =
A.Var.make (Bindlib.name_of old_scope_let_var, scope_let.scope_let_pos)
in
let new_scope_let_var = A.new_var (Bindlib.name_of old_scope_let_var) in
let new_scope_let_expr = translate_expr ctx scope_let.scope_let_expr in
let new_ctx = D.VarMap.add old_scope_let_var new_scope_let_var ctx in
let new_ctx =
D.VarMap.add (D.Var.t old_scope_let_var) new_scope_let_var ctx
in
let new_scope_next = translate_scope_lets decl_ctx new_ctx scope_let_next in
let new_scope_next = Bindlib.bind_var new_scope_let_var new_scope_next in
Bindlib.box_apply2
@ -148,31 +147,29 @@ let rec translate_scope_lets
let rec translate_scopes
(decl_ctx : D.decl_ctx)
(ctx : A.Var.t D.VarMap.t)
(scopes : D.expr D.scopes) : A.expr D.scopes Bindlib.box =
(ctx : 'm ctx)
(scopes : ('m D.expr, 'm) D.scopes) : ('m A.expr, 'm) D.scopes Bindlib.box =
match scopes with
| Nil -> Bindlib.box D.Nil
| ScopeDef scope_def ->
let old_scope_var, scope_next = Bindlib.unbind scope_def.scope_next in
let new_scope_var =
A.Var.make (D.ScopeName.get_info scope_def.scope_name)
A.new_var (Marked.unmark (D.ScopeName.get_info scope_def.scope_name))
in
let old_scope_input_var, scope_body_expr =
Bindlib.unbind scope_def.scope_body.scope_body_expr
in
let new_scope_input_var =
A.Var.make
( Bindlib.name_of old_scope_input_var,
Pos.get_position (D.ScopeName.get_info scope_def.scope_name) )
let new_scope_input_var = A.new_var (Bindlib.name_of old_scope_input_var) in
let new_ctx =
D.VarMap.add (D.Var.t old_scope_input_var) new_scope_input_var ctx
in
let new_ctx = D.VarMap.add old_scope_input_var new_scope_input_var ctx in
let new_scope_body_expr =
translate_scope_lets decl_ctx new_ctx scope_body_expr
in
let new_scope_body_expr =
Bindlib.bind_var new_scope_input_var new_scope_body_expr
in
let new_scope : A.expr D.scope_body Bindlib.box =
let new_scope : ('m A.expr, 'm) D.scope_body Bindlib.box =
Bindlib.box_apply
(fun new_scope_body_expr ->
{
@ -184,7 +181,7 @@ let rec translate_scopes
})
new_scope_body_expr
in
let new_ctx = D.VarMap.add old_scope_var new_scope_var new_ctx in
let new_ctx = D.VarMap.add (D.Var.t old_scope_var) new_scope_var new_ctx in
let scope_next =
Bindlib.bind_var new_scope_var
(translate_scopes decl_ctx new_ctx scope_next)
@ -199,7 +196,7 @@ let rec translate_scopes
})
new_scope scope_next
let translate_program (prgm : D.program) : A.program =
let translate_program (prgm : 'm D.program) : 'm A.program =
{
scopes =
Bindlib.unbox (translate_scopes prgm.decl_ctx D.VarMap.empty prgm.scopes);

4
compiler/lcalc/compile_with_exceptions.mli
View File

@ -15,6 +15,6 @@
the License. *)
(** Translation from the default calculus to the lambda calculus. This
translation uses exceptions handle empty default terms. *)
translation uses exceptions to handle empty default terms. *)
val translate_program : Dcalc.Ast.program -> Ast.program
val translate_program : 'm Dcalc.Ast.program -> 'm Ast.program

196
compiler/lcalc/compile_without_exceptions.ml
View File

@ -40,12 +40,12 @@ module A = Ast
hoisted and later handled by the [translate_expr] function. Every other
cases is found in the translate_and_hoist function. *)
type hoists = D.expr Pos.marked A.VarMap.t
type 'm hoists = 'm D.marked_expr A.VarMap.t
(** Hoists definition. It represent bindings between [A.Var.t] and [D.expr]. *)
type info = {
expr : A.expr Pos.marked Bindlib.box;
var : A.expr Bindlib.var;
type 'm info = {
expr : 'm A.marked_expr Bindlib.box;
var : 'm A.expr Bindlib.var;
is_pure : bool;
}
(** Information about each encontered Dcalc variable is stored inside a context
@ -54,19 +54,20 @@ type info = {
indicating whenever the variable can be an EmptyError and hence should be
matched (false) or if it never can be EmptyError (true). *)
let pp_info (fmt : Format.formatter) (info : info) =
let pp_info (fmt : Format.formatter) (info : 'm info) =
Format.fprintf fmt "{var: %a; is_pure: %b}" Print.format_var info.var
info.is_pure
type ctx = {
type 'm ctx = {
decl_ctx : D.decl_ctx;
vars : info D.VarMap.t;
vars : 'm info D.VarMap.t;
(** information context about variables in the current scope *)
}
let _pp_ctx (fmt : Format.formatter) (ctx : ctx) =
let pp_binding (fmt : Format.formatter) ((v, info) : D.Var.t * info) =
Format.fprintf fmt "%a: %a" Dcalc.Print.format_var v pp_info info
let _pp_ctx (fmt : Format.formatter) (ctx : 'm ctx) =
let pp_binding (fmt : Format.formatter) ((v, info) : D.Var.t * 'm info) =
Format.fprintf fmt "%a: %a" Dcalc.Print.format_var (D.Var.get v) pp_info
info
in
let pp_bindings =
@ -79,10 +80,10 @@ let _pp_ctx (fmt : Format.formatter) (ctx : ctx) =
(** [find ~info n ctx] is a warpper to ocaml's Map.find that handle errors in a
slightly better way. *)
let find ?(info : string = "none") (n : D.Var.t) (ctx : ctx) : info =
let find ?(info : string = "none") (n : 'm D.var) (ctx : 'm ctx) : 'm info =
(* let _ = Format.asprintf "Searching for variable %a inside context %a"
Dcalc.Print.format_var n pp_ctx ctx |> Cli.debug_print in *)
try D.VarMap.find n ctx.vars
try D.VarMap.find (D.Var.t n) ctx.vars
with Not_found ->
Errors.raise_spanned_error Pos.no_pos
"Internal Error: Variable %a was not found in the current environment. \
@ -93,16 +94,17 @@ let find ?(info : string = "none") (n : D.Var.t) (ctx : ctx) : info =
var, creating a unique corresponding variable in Lcalc, with the
corresponding expression, and the boolean is_pure. It is usefull for
debuging purposes as it printing each of the Dcalc/Lcalc variable pairs. *)
let add_var (pos : Pos.t) (var : D.Var.t) (is_pure : bool) (ctx : ctx) : ctx =
let new_var = A.Var.make (Bindlib.name_of var, pos) in
let expr = A.make_var (new_var, pos) in
let add_var (mark : 'm D.mark) (var : 'm D.var) (is_pure : bool) (ctx : 'm ctx)
: 'm ctx =
let new_var = A.new_var (Bindlib.name_of var) in
let expr = A.make_var (new_var, mark) in
(* Cli.debug_print @@ Format.asprintf "D.%a |-> A.%a" Dcalc.Print.format_var
var Print.format_var new_var; *)
{
ctx with
vars =
D.VarMap.update var
D.VarMap.update (D.Var.t var)
(fun _ -> Some { expr; var = new_var; is_pure })
ctx.vars;
}
@ -112,10 +114,11 @@ let add_var (pos : Pos.t) (var : D.Var.t) (is_pure : bool) (ctx : ctx) : ctx =
Since positions where there is thunked expressions is exactly where we will
put option expressions. Hence, the transformation simply reduce [unit -> 'a]
into ['a option] recursivly. There is no polymorphism inside catala. *)
let rec translate_typ (tau : D.typ Pos.marked) : D.typ Pos.marked =
(Fun.flip Pos.same_pos_as) tau
let rec translate_typ (tau : D.typ Marked.pos) : D.typ Marked.pos =
(Fun.flip Marked.same_mark_as)
tau
begin
match Pos.unmark tau with
match Marked.unmark tau with
| D.TLit l -> D.TLit l
| D.TTuple (ts, s) -> D.TTuple (List.map translate_typ ts, s)
| D.TEnum (ts, en) -> D.TEnum (List.map translate_typ ts, en)
@ -160,10 +163,10 @@ let disjoint_union_maps (pos : Pos.t) (cs : 'a A.VarMap.t list) : 'a A.VarMap.t
the equivalence between the execution of e and the execution of e' are
equivalent in an environement where each variable v, where (v, e_v) is in
hoists, has the non-empty value in e_v. *)
let rec translate_and_hoist (ctx : ctx) (e : D.expr Pos.marked) :
A.expr Pos.marked Bindlib.box * hoists =
let pos = Pos.get_position e in
match Pos.unmark e with
let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.marked_expr) :
'm A.marked_expr Bindlib.box * 'm hoists =
let pos = Marked.get_mark e in
match Marked.unmark e with
(* empty-producing/using terms. We hoist those. (D.EVar in some cases,
EApp(D.EVar _, [ELit LUnit]), EDefault _, ELit LEmptyDefault) I'm unsure
about assert. *)
@ -172,49 +175,47 @@ let rec translate_and_hoist (ctx : ctx) (e : D.expr Pos.marked) :
current context) is thunked, hence matched in the next case. This
assumption can change in the future, and this case is here for this
reason. *)
let v, pos_v = v in
if not (find ~info:"search for a variable" v ctx).is_pure then
let v' = A.Var.make (Bindlib.name_of v, pos_v) in
let v' = A.new_var (Bindlib.name_of v) in
(* Cli.debug_print @@ Format.asprintf "Found an unpure variable %a,
created a variable %a to replace it" Dcalc.Print.format_var v
Print.format_var v'; *)
A.make_var (v', pos), A.VarMap.singleton v' e
A.make_var (v', pos), A.VarMap.singleton (A.Var.t v') e
else (find ~info:"should never happend" v ctx).expr, A.VarMap.empty
| D.EApp ((D.EVar (v, pos_v), p), [(D.ELit D.LUnit, _)]) ->
| D.EApp ((D.EVar v, p), [(D.ELit D.LUnit, _)]) ->
if not (find ~info:"search for a variable" v ctx).is_pure then
let v' = A.Var.make (Bindlib.name_of v, pos_v) in
let v' = A.new_var (Bindlib.name_of v) in
(* Cli.debug_print @@ Format.asprintf "Found an unpure variable %a,
created a variable %a to replace it" Dcalc.Print.format_var v
Print.format_var v'; *)
A.make_var (v', pos), A.VarMap.singleton v' (D.EVar (v, pos_v), p)
A.make_var (v', pos), A.VarMap.singleton (A.Var.t v') (D.EVar v, p)
else
Errors.raise_spanned_error pos
Errors.raise_spanned_error (D.pos e)
"Internal error: an pure variable was found in an unpure environment."
| D.EDefault (_exceptions, _just, _cons) ->
let v' = A.Var.make ("default_term", pos) in
A.make_var (v', pos), A.VarMap.singleton v' e
let v' = A.new_var "default_term" in
A.make_var (v', pos), A.VarMap.singleton (A.Var.t v') e
| D.ELit D.LEmptyError ->
let v' = A.Var.make ("empty_litteral", pos) in
A.make_var (v', pos), A.VarMap.singleton v' e
let v' = A.new_var "empty_litteral" in
A.make_var (v', pos), A.VarMap.singleton (A.Var.t v') e
(* This one is a very special case. It transform an unpure expression
environement to a pure expression. *)
| ErrorOnEmpty arg ->
(* [ match arg with | None -> raise NoValueProvided | Some v -> {{ v }} ] *)
let silent_var = A.Var.make ("_", pos) in
let x = A.Var.make ("non_empty_argument", pos) in
let silent_var = A.new_var "_" in
let x = A.new_var "non_empty_argument" in
let arg' = translate_expr ctx arg in
( A.make_matchopt_with_abs_arms arg'
(A.make_abs [| silent_var |]
(Bindlib.box (A.ERaise A.NoValueProvided, pos))
pos
[D.TAny, pos]
[D.TAny, D.pos e]
pos)
(A.make_abs [| x |] (A.make_var (x, pos)) pos [D.TAny, pos] pos),
(A.make_abs [| x |] (A.make_var (x, pos)) [D.TAny, D.pos e] pos),
A.VarMap.empty )
(* pure terms *)
| D.ELit l -> A.elit (translate_lit l pos) pos, A.VarMap.empty
| D.ELit l -> A.elit (translate_lit l (D.pos e)) pos, A.VarMap.empty
| D.EIfThenElse (e1, e2, e3) ->
let e1', h1 = translate_and_hoist ctx e1 in
let e2', h2 = translate_and_hoist ctx e2 in
@ -224,13 +225,13 @@ let rec translate_and_hoist (ctx : ctx) (e : D.expr Pos.marked) :
(*(* equivalent code : *) let e' = let+ e1' = e1' and+ e2' = e2' and+ e3' =
e3' in (A.EIfThenElse (e1', e2', e3'), pos) in *)
e', disjoint_union_maps pos [h1; h2; h3]
e', disjoint_union_maps (D.pos e) [h1; h2; h3]
| D.EAssert e1 ->
(* same behavior as in the ICFP paper: if e1 is empty, then no error is
raised. *)
let e1', h1 = translate_and_hoist ctx e1 in
A.eassert e1' pos, h1
| D.EAbs ((binder, pos_binder), ts) ->
| D.EAbs (binder, ts) ->
let vars, body = Bindlib.unmbind binder in
let ctx, lc_vars =
ArrayLabels.fold_right vars ~init:(ctx, []) ~f:(fun var (ctx, lc_vars) ->
@ -252,8 +253,7 @@ let rec translate_and_hoist (ctx : ctx) (e : D.expr Pos.marked) :
let new_binder = Bindlib.bind_mvar lc_vars new_body in
( Bindlib.box_apply
(fun new_binder ->
A.EAbs ((new_binder, pos_binder), List.map translate_typ ts), pos)
(fun new_binder -> A.EAbs (new_binder, List.map translate_typ ts), pos)
new_binder,
hoists )
| EApp (e1, args) ->
@ -262,7 +262,7 @@ let rec translate_and_hoist (ctx : ctx) (e : D.expr Pos.marked) :
args |> List.map (translate_and_hoist ctx) |> List.split
in
let hoists = disjoint_union_maps pos (h1 :: h_args) in
let hoists = disjoint_union_maps (D.pos e) (h1 :: h_args) in
let e' = A.eapp e1' args' pos in
e', hoists
| ETuple (args, s) ->
@ -270,7 +270,7 @@ let rec translate_and_hoist (ctx : ctx) (e : D.expr Pos.marked) :
args |> List.map (translate_and_hoist ctx) |> List.split
in
let hoists = disjoint_union_maps pos h_args in
let hoists = disjoint_union_maps (D.pos e) h_args in
A.etuple args' s pos, hoists
| ETupleAccess (e1, i, s, ts) ->
let e1', hoists = translate_and_hoist ctx e1 in
@ -286,75 +286,72 @@ let rec translate_and_hoist (ctx : ctx) (e : D.expr Pos.marked) :
cases |> List.map (translate_and_hoist ctx) |> List.split
in
let hoists = disjoint_union_maps pos (h1 :: h_cases) in
let hoists = disjoint_union_maps (D.pos e) (h1 :: h_cases) in
let e' = A.ematch e1' cases' en pos in
e', hoists
| EArray es ->
let es', hoists = es |> List.map (translate_and_hoist ctx) |> List.split in
A.earray es' pos, disjoint_union_maps pos hoists
A.earray es' pos, disjoint_union_maps (D.pos e) hoists
| EOp op -> Bindlib.box (A.EOp op, pos), A.VarMap.empty
and translate_expr ?(append_esome = true) (ctx : ctx) (e : D.expr Pos.marked) :
A.expr Pos.marked Bindlib.box =
and translate_expr ?(append_esome = true) (ctx : 'm ctx) (e : 'm D.marked_expr)
: 'm A.marked_expr Bindlib.box =
let e', hoists = translate_and_hoist ctx e in
let hoists = A.VarMap.bindings hoists in
let _pos = Pos.get_position e in
let _pos = Marked.get_mark e in
(* build the hoists *)
(* Cli.debug_print @@ Format.asprintf "hoist for the expression: [%a]"
(Format.pp_print_list Print.format_var) (List.map fst hoists); *)
ListLabels.fold_left hoists
~init:(if append_esome then A.make_some e' else e')
~f:(fun acc (v, (hoist, pos_hoist)) ->
~f:(fun acc (v, (hoist, mark_hoist)) ->
(* Cli.debug_print @@ Format.asprintf "hoist using A.%a" Print.format_var
v; *)
let c' : A.expr Pos.marked Bindlib.box =
let c' : 'm A.marked_expr Bindlib.box =
match hoist with
(* Here we have to handle only the cases appearing in hoists, as defined
the [translate_and_hoist] function. *)
| D.EVar v ->
(find ~info:"should never happend" (Pos.unmark v) ctx).expr
| D.EVar v -> (find ~info:"should never happend" v ctx).expr
| D.EDefault (excep, just, cons) ->
let excep' = List.map (translate_expr ctx) excep in
let just' = translate_expr ctx just in
let cons' = translate_expr ctx cons in
(* calls handle_option. *)
A.make_app
(A.make_var (A.handle_default_opt, pos_hoist))
(A.make_var (A.Var.get A.handle_default_opt, mark_hoist))
[
Bindlib.box_apply
(fun excep' -> A.EArray excep', pos_hoist)
(fun excep' -> A.EArray excep', mark_hoist)
(Bindlib.box_list excep');
just';
cons';
]
pos_hoist
| D.ELit D.LEmptyError -> A.make_none pos_hoist
mark_hoist
| D.ELit D.LEmptyError -> A.make_none mark_hoist
| D.EAssert arg ->
let arg' = translate_expr ctx arg in
(* [ match arg with | None -> raise NoValueProvided | Some v -> assert
{{ v }} ] *)
let silent_var = A.Var.make ("_", pos_hoist) in
let x = A.Var.make ("assertion_argument", pos_hoist) in
let silent_var = A.new_var "_" in
let x = A.new_var "assertion_argument" in
A.make_matchopt_with_abs_arms arg'
(A.make_abs [| silent_var |]
(Bindlib.box (A.ERaise A.NoValueProvided, pos_hoist))
pos_hoist
[D.TAny, pos_hoist]
pos_hoist)
(Bindlib.box (A.ERaise A.NoValueProvided, mark_hoist))
[D.TAny, D.mark_pos mark_hoist]
mark_hoist)
(A.make_abs [| x |]
(Bindlib.box_apply
(fun arg -> A.EAssert arg, pos_hoist)
(A.make_var (x, pos_hoist)))
pos_hoist
[D.TAny, pos_hoist]
pos_hoist)
(fun arg -> A.EAssert arg, mark_hoist)
(A.make_var (x, mark_hoist)))
[D.TAny, D.mark_pos mark_hoist]
mark_hoist)
| _ ->
Errors.raise_spanned_error pos_hoist
Errors.raise_spanned_error (D.mark_pos mark_hoist)
"Internal Error: An term was found in a position where it should \
not be"
in
@ -363,11 +360,14 @@ and translate_expr ?(append_esome = true) (ctx : ctx) (e : D.expr Pos.marked) :
] *)
(* Cli.debug_print @@ Format.asprintf "build matchopt using %a"
Print.format_var v; *)
A.make_matchopt pos_hoist v (D.TAny, pos_hoist) c' (A.make_none pos_hoist)
acc)
A.make_matchopt mark_hoist (A.Var.get v)
(D.TAny, D.mark_pos mark_hoist)
c' (A.make_none mark_hoist) acc)
let rec translate_scope_let (ctx : ctx) (lets : D.expr D.scope_body_expr) :
A.expr D.scope_body_expr Bindlib.box =
let rec translate_scope_let
(ctx : 'm ctx)
(lets : ('m D.expr, 'm) D.scope_body_expr) :
('m A.expr, 'm) D.scope_body_expr Bindlib.box =
match lets with
| Result e ->
Bindlib.box_apply
@ -377,7 +377,7 @@ let rec translate_scope_let (ctx : ctx) (lets : D.expr D.scope_body_expr) :
{
scope_let_kind = SubScopeVarDefinition;
scope_let_typ = typ;
scope_let_expr = D.EAbs ((binder, _), _), _;
scope_let_expr = D.EAbs (binder, _), emark;
scope_let_next = next;
scope_let_pos = pos;
} ->
@ -389,7 +389,8 @@ let rec translate_scope_let (ctx : ctx) (lets : D.expr D.scope_body_expr) :
let var, next = Bindlib.unbind next in
(* Cli.debug_print @@ Format.asprintf "unbinding %a" Dcalc.Print.format_var
var; *)
let ctx' = add_var pos var var_is_pure ctx in
let vmark = D.map_mark (fun _ -> pos) (fun _ -> typ) emark in
let ctx' = add_var vmark var var_is_pure ctx in
let new_var = (find ~info:"variable that was just created" var ctx').var in
let new_next = translate_scope_let ctx' next in
Bindlib.box_apply2
@ -408,7 +409,7 @@ let rec translate_scope_let (ctx : ctx) (lets : D.expr D.scope_body_expr) :
{
scope_let_kind = SubScopeVarDefinition;
scope_let_typ = typ;
scope_let_expr = (D.ErrorOnEmpty _, _) as expr;
scope_let_expr = (D.ErrorOnEmpty _, emark) as expr;
scope_let_next = next;
scope_let_pos = pos;
} ->
@ -417,7 +418,8 @@ let rec translate_scope_let (ctx : ctx) (lets : D.expr D.scope_body_expr) :
let var, next = Bindlib.unbind next in
(* Cli.debug_print @@ Format.asprintf "unbinding %a" Dcalc.Print.format_var
var; *)
let ctx' = add_var pos var var_is_pure ctx in
let vmark = D.map_mark (fun _ -> pos) (fun _ -> typ) emark in
let ctx' = add_var vmark var var_is_pure ctx in
let new_var = (find ~info:"variable that was just created" var ctx').var in
Bindlib.box_apply2
(fun new_expr new_next ->
@ -459,7 +461,7 @@ let rec translate_scope_let (ctx : ctx) (lets : D.expr D.scope_body_expr) :
can do so by looking at the typ of the destructuring: if it's
thunked, then the variable is context. If it's not thunked, it's a
regular input. *)
match Pos.unmark typ with
match Marked.unmark typ with
| D.TArrow ((D.TLit D.TUnit, _), _) -> false
| _ -> true)
| ScopeVarDefinition | SubScopeVarDefinition | CallingSubScope
@ -469,7 +471,10 @@ let rec translate_scope_let (ctx : ctx) (lets : D.expr D.scope_body_expr) :
let var, next = Bindlib.unbind next in
(* Cli.debug_print @@ Format.asprintf "unbinding %a" Dcalc.Print.format_var
var; *)
let ctx' = add_var pos var var_is_pure ctx in
let vmark =
D.map_mark (fun _ -> pos) (fun _ -> typ) (Marked.get_mark expr)
in
let ctx' = add_var vmark var var_is_pure ctx in
let new_var = (find ~info:"variable that was just created" var ctx').var in
Bindlib.box_apply2
(fun new_expr new_next ->
@ -486,8 +491,9 @@ let rec translate_scope_let (ctx : ctx) (lets : D.expr D.scope_body_expr) :
let translate_scope_body
(scope_pos : Pos.t)
(ctx : ctx)
(body : D.expr D.scope_body) : A.expr D.scope_body Bindlib.box =
(ctx : 'm ctx)
(body : ('m D.expr, 'm) D.scope_body) :
('m A.expr, 'm) D.scope_body Bindlib.box =
match body with
| {
scope_body_expr = result;
@ -495,7 +501,14 @@ let translate_scope_body
scope_body_output_struct = output_struct;
} ->
let v, lets = Bindlib.unbind result in
let ctx' = add_var scope_pos v true ctx in
let vmark =
let m =
match lets with
| Result e | ScopeLet { scope_let_expr = e; _ } -> Marked.get_mark e
in
D.map_mark (fun _ -> scope_pos) (fun ty -> ty) m
in
let ctx' = add_var vmark v true ctx in
let v' = (find ~info:"variable that was just created" v ctx').var in
Bindlib.box_apply
(fun new_expr ->
@ -506,18 +519,23 @@ let translate_scope_body
})
(Bindlib.bind_var v' (translate_scope_let ctx' lets))
let rec translate_scopes (ctx : ctx) (scopes : D.expr D.scopes) :
A.expr D.scopes Bindlib.box =
let rec translate_scopes (ctx : 'm ctx) (scopes : ('m D.expr, 'm) D.scopes) :
('m A.expr, 'm) D.scopes Bindlib.box =
match scopes with
| Nil -> Bindlib.box D.Nil
| ScopeDef { scope_name; scope_body; scope_next } ->
let scope_var, next = Bindlib.unbind scope_next in
let new_ctx = add_var Pos.no_pos scope_var true ctx in
let vmark =
match Bindlib.unbind scope_body.scope_body_expr with
| _, (Result e | ScopeLet { scope_let_expr = e; _ }) -> Marked.get_mark e
in
let new_ctx = add_var vmark scope_var true ctx in
let new_scope_name =
(find ~info:"variable that was just created" scope_var new_ctx).var
in
let scope_pos = Pos.get_position (D.ScopeName.get_info scope_name) in
let scope_pos = Marked.get_mark (D.ScopeName.get_info scope_name) in
let new_body = translate_scope_body scope_pos ctx scope_body in
let tail = translate_scopes new_ctx next in
@ -528,7 +546,7 @@ let rec translate_scopes (ctx : ctx) (scopes : D.expr D.scopes) :
new_body
(Bindlib.bind_var new_scope_name tail)
let translate_program (prgm : D.program) : A.program =
let translate_program (prgm : 'm D.program) : 'm A.program =
let inputs_structs =
D.fold_left_scope_defs prgm.scopes ~init:[] ~f:(fun acc scope_def _ ->
scope_def.D.scope_body.scope_body_input_struct :: acc)

2
compiler/lcalc/compile_without_exceptions.mli
View File

@ -19,4 +19,4 @@
transformation is one piece to permit to compile toward legacy languages
that does not contains exceptions. *)
val translate_program : Dcalc.Ast.program -> Ast.program
val translate_program : 'm Dcalc.Ast.program -> 'm Ast.program

2
compiler/lcalc/dune
View File

@ -1,7 +1,7 @@
(library
(name lcalc)
(public_name catala.lcalc)
(libraries bindlib dcalc scopelang runtime)
(libraries bindlib ubase dcalc scopelang catala.runtime_ocaml)
(preprocess
(pps visitors.ppx)))

69
compiler/lcalc/optimizations.ml
View File

@ -15,19 +15,20 @@
the License. *)
open Utils
open Ast
module D = Dcalc.Ast
let ( let+ ) x f = Bindlib.box_apply f x
let ( and+ ) x y = Bindlib.box_pair x y
let visitor_map
(t : 'a -> expr Pos.marked -> expr Pos.marked Bindlib.box)
(t : 'a -> 'm marked_expr -> 'm marked_expr Bindlib.box)
(ctx : 'a)
(e : expr Pos.marked) : expr Pos.marked Bindlib.box =
(e : 'm marked_expr) : 'm marked_expr Bindlib.box =
(* calls [t ctx] on every direct childs of [e], then rebuild an abstract
syntax tree modified. Used in other transformations. *)
let default_mark e' = Pos.same_pos_as e' e in
match Pos.unmark e with
| EVar (v, _pos) ->
let default_mark e' = Marked.same_mark_as e' e in
match Marked.unmark e with
| EVar v ->
let+ v = Bindlib.box_var v in
default_mark @@ v
| ETuple (args, n) ->
@ -46,11 +47,11 @@ let visitor_map
| EArray args ->
let+ args = args |> List.map (t ctx) |> Bindlib.box_list in
default_mark @@ EArray args
| EAbs ((binder, pos_binder), ts) ->
| EAbs (binder, ts) ->
let vars, body = Bindlib.unmbind binder in
let body = t ctx body in
let+ binder = Bindlib.bind_mvar vars body in
default_mark @@ EAbs ((binder, pos_binder), ts)
default_mark @@ EAbs (binder, ts)
| EApp (e1, args) ->
let+ e1 = t ctx e1
and+ args = args |> List.map (t ctx) |> Bindlib.box_list in
@ -66,10 +67,9 @@ let visitor_map
default_mark @@ ECatch (e1, exn, e2)
| ERaise _ | ELit _ | EOp _ -> Bindlib.box e
let rec iota_expr (_ : unit) (e : expr Pos.marked) : expr Pos.marked Bindlib.box
=
let default_mark e' = Pos.mark (Pos.get_position e) e' in
match Pos.unmark e with
let rec iota_expr (_ : unit) (e : 'm marked_expr) : 'm marked_expr Bindlib.box =
let default_mark e' = Marked.mark (Marked.get_mark e) e' in
match Marked.unmark e with
| EMatch ((EInj (e1, i, n', _ts), _), cases, n)
when Dcalc.Ast.EnumName.compare n n' = 0 ->
let+ e1 = visitor_map iota_expr () e1
@ -86,42 +86,45 @@ let rec iota_expr (_ : unit) (e : expr Pos.marked) : expr Pos.marked Bindlib.box
visitor_map iota_expr () e'
| _ -> visitor_map iota_expr () e
let rec beta_expr (_ : unit) (e : expr Pos.marked) : expr Pos.marked Bindlib.box
=
let default_mark e' = Pos.same_pos_as e' e in
match Pos.unmark e with
let rec beta_expr (_ : unit) (e : 'm marked_expr) : 'm marked_expr Bindlib.box =
let default_mark e' = Marked.same_mark_as e' e in
match Marked.unmark e with
| EApp (e1, args) -> (
let+ e1 = beta_expr () e1
and+ args = List.map (beta_expr ()) args |> Bindlib.box_list in
match Pos.unmark e1 with
| EAbs ((binder, _pos_binder), _ts) ->
match Marked.unmark e1 with
| EAbs (binder, _ts) ->
let (_ : (_, _) Bindlib.mbinder) = binder in
Bindlib.msubst binder (List.map fst args |> Array.of_list)
| _ -> default_mark @@ EApp (e1, args))
| _ -> visitor_map beta_expr () e
let iota_optimizations (p : program) : program =
let new_scopes = Dcalc.Ast.map_exprs_in_scopes ~f:(iota_expr ()) p.scopes in
{ p with scopes = Bindlib.unbox new_scopes }
let iota_optimizations (p : 'm program) : 'm program =
let new_scopes =
Dcalc.Ast.map_exprs_in_scopes ~f:(iota_expr ()) ~varf:(fun v -> v) p.scopes
in
{ p with D.scopes = Bindlib.unbox new_scopes }
(* TODO: beta optimizations apply inlining of the program. We left the inclusion
of beta-optimization as future work since its produce code that is harder to
read, and can produce exponential blowup of the size of the generated
program. *)
let _beta_optimizations (p : program) : program =
let new_scopes = Dcalc.Ast.map_exprs_in_scopes ~f:(beta_expr ()) p.scopes in
let _beta_optimizations (p : 'm program) : 'm program =
let new_scopes =
Dcalc.Ast.map_exprs_in_scopes ~f:(beta_expr ()) ~varf:(fun v -> v) p.scopes
in
{ p with scopes = Bindlib.unbox new_scopes }
let rec peephole_expr (_ : unit) (e : expr Pos.marked) :
expr Pos.marked Bindlib.box =
let default_mark e' = Pos.mark (Pos.get_position e) e' in
let rec peephole_expr (_ : unit) (e : 'm marked_expr) :
'm marked_expr Bindlib.box =
let default_mark e' = Marked.mark (Marked.get_mark e) e' in
match Pos.unmark e with
match Marked.unmark e with
| EIfThenElse (e1, e2, e3) -> (
let+ e1 = peephole_expr () e1
and+ e2 = peephole_expr () e2
and+ e3 = peephole_expr () e3 in
match Pos.unmark e1 with
match Marked.unmark e1 with
| ELit (LBool true)
| EApp ((EOp (Unop (Log _)), _), [(ELit (LBool true), _)]) ->
e2
@ -131,7 +134,7 @@ let rec peephole_expr (_ : unit) (e : expr Pos.marked) :
| _ -> default_mark @@ EIfThenElse (e1, e2, e3))
| ECatch (e1, except, e2) -> (
let+ e1 = peephole_expr () e1 and+ e2 = peephole_expr () e2 in
match Pos.unmark e1, Pos.unmark e2 with
match Marked.unmark e1, Marked.unmark e2 with
| ERaise except', ERaise except'' when except' = except && except = except''
->
default_mark @@ ERaise except
@ -140,11 +143,13 @@ let rec peephole_expr (_ : unit) (e : expr Pos.marked) :
| _ -> default_mark @@ ECatch (e1, except, e2))
| _ -> visitor_map peephole_expr () e
let peephole_optimizations (p : program) : program =
let peephole_optimizations (p : 'm program) : 'm program =
let new_scopes =
Dcalc.Ast.map_exprs_in_scopes ~f:(peephole_expr ()) p.scopes
Dcalc.Ast.map_exprs_in_scopes ~f:(peephole_expr ())
~varf:(fun v -> v)
p.scopes
in
{ p with scopes = Bindlib.unbox new_scopes }
let optimize_program (p : program) : program =
p |> iota_optimizations |> peephole_optimizations
let optimize_program (p : 'm program) : Dcalc.Ast.untyped program =
p |> iota_optimizations |> peephole_optimizations |> untype_program

4
compiler/lcalc/optimizations.mli
View File

@ -16,4 +16,6 @@
open Ast
val optimize_program : program -> program
val optimize_program : 'm program -> Dcalc.Ast.untyped program
(** Warning/todo: no effort was yet made to ensure correct propagation of type
annotations in the typed case *)

83
compiler/lcalc/print.ml
View File

@ -17,22 +17,10 @@
open Utils
open Ast
let is_uppercase (x : CamomileLibraryDefault.Camomile.UChar.t) : bool =
try
match CamomileLibraryDefault.Camomile.UCharInfo.general_category x with
| `Ll -> false
| `Lu -> true
| _ -> false
with _ -> true
let begins_with_uppercase (s : string) : bool =
let first_letter = CamomileLibraryDefault.Camomile.UTF8.get s 0 in
is_uppercase first_letter
(** {b Note:} (EmileRolley) seems to be factorizable with
Dcalc.Print.format_lit. *)
let format_lit (fmt : Format.formatter) (l : lit Pos.marked) : unit =
match Pos.unmark l with
let format_lit (fmt : Format.formatter) (l : lit Marked.pos) : unit =
match Marked.unmark l with
| LBool b -> Dcalc.Print.format_lit_style fmt (string_of_bool b)
| LInt i -> Dcalc.Print.format_lit_style fmt (Runtime.integer_to_string i)
| LUnit -> Dcalc.Print.format_lit_style fmt "()"
@ -68,26 +56,26 @@ let format_keyword (fmt : Format.formatter) (s : string) : unit =
let format_punctuation (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ANSITerminal.cyan]) s
let needs_parens (e : expr Pos.marked) : bool =
match Pos.unmark e with EAbs _ | ETuple (_, Some _) -> true | _ -> false
let needs_parens (e : 'm marked_expr) : bool =
match Marked.unmark e with EAbs _ | ETuple (_, Some _) -> true | _ -> false
let format_var (fmt : Format.formatter) (v : Var.t) : unit =
let format_var (fmt : Format.formatter) (v : 'm Ast.var) : unit =
Format.fprintf fmt "%s_%d" (Bindlib.name_of v) (Bindlib.uid_of v)
let rec format_expr
?(debug : bool = false)
(ctx : Dcalc.Ast.decl_ctx)
(fmt : Format.formatter)
(e : expr Pos.marked) : unit =
(e : 'm marked_expr) : unit =
let format_expr = format_expr ctx ~debug in
let format_with_parens (fmt : Format.formatter) (e : expr Pos.marked) =
let format_with_parens (fmt : Format.formatter) (e : 'm marked_expr) =
if needs_parens e then
Format.fprintf fmt "%a%a%a" format_punctuation "(" format_expr e
format_punctuation ")"
else Format.fprintf fmt "%a" format_expr e
in
match Pos.unmark e with
| EVar v -> Format.fprintf fmt "%a" format_var (Pos.unmark v)
match Marked.unmark e with
| EVar v -> Format.fprintf fmt "%a" format_var v
| ETuple (es, None) ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" format_punctuation "("
(Format.pp_print_list
@ -136,23 +124,23 @@ let rec format_expr
format_expr e))
(List.combine es
(List.map fst (Dcalc.Ast.EnumMap.find e_name ctx.ctx_enums)))
| ELit l -> Format.fprintf fmt "%a" format_lit (Pos.same_pos_as l e)
| EApp ((EAbs ((binder, _), taus), _), args) ->
| ELit l ->
Format.fprintf fmt "%a" format_lit (Marked.mark (Dcalc.Ast.pos e) l)
| 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) ->
(fun fmt ((x, tau), arg) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@ %a@]@\n"
format_keyword "let" format_var x format_punctuation ":"
(Dcalc.Print.format_typ ctx)
tau format_punctuation "=" format_expr arg format_keyword "in"))
xs_tau_arg format_expr body
| EAbs ((binder, _), taus) ->
(Marked.unmark tau) format_punctuation "=" format_expr arg
format_keyword "in"))
(List.combine (List.combine (Array.to_list xs) taus) args)
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 %a@ %a@]" format_punctuation "λ"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
@ -160,21 +148,22 @@ let rec format_expr
Format.fprintf fmt "%a%a%a %a%a" format_punctuation "(" format_var x
format_punctuation ":"
(Dcalc.Print.format_typ ctx)
tau format_punctuation ")"))
xs_tau format_punctuation "→" format_expr body
(Marked.unmark tau) format_punctuation ")"))
(List.combine (Array.to_list xs) taus)
format_punctuation "→" format_expr body
| EApp
((EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), [arg1; arg2])
->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" Dcalc.Print.format_binop
(op, Pos.no_pos) format_with_parens arg1 format_with_parens arg2
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" Dcalc.Print.format_binop op
format_with_parens arg1 format_with_parens arg2
| EApp ((EOp (Binop op), _), [arg1; arg2]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1
Dcalc.Print.format_binop (op, Pos.no_pos) format_with_parens arg2
Dcalc.Print.format_binop op format_with_parens arg2
| EApp ((EOp (Unop (Log _)), _), [arg1]) when not debug ->
Format.fprintf fmt "%a" format_with_parens arg1
| EApp ((EOp (Unop op), _), [arg1]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Dcalc.Print.format_unop
(op, Pos.no_pos) format_with_parens arg1
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Dcalc.Print.format_unop op
format_with_parens arg1
| EApp (f, args) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_expr f
(Format.pp_print_list
@ -185,12 +174,9 @@ let rec format_expr
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@]" format_keyword "if"
format_expr e1 format_keyword "then" format_expr e2 format_keyword "else"
format_expr e3
| EOp (Ternop op) ->
Format.fprintf fmt "%a" Dcalc.Print.format_ternop (op, Pos.no_pos)
| EOp (Binop op) ->
Format.fprintf fmt "%a" Dcalc.Print.format_binop (op, Pos.no_pos)
| EOp (Unop op) ->
Format.fprintf fmt "%a" Dcalc.Print.format_unop (op, Pos.no_pos)
| EOp (Ternop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_ternop op
| EOp (Binop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_binop op
| EOp (Unop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_unop op
| ECatch (e1, exn, e2) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a ->@ %a@]" format_keyword "try"
format_with_parens e1 format_keyword "with" format_exception exn
@ -202,14 +188,13 @@ let rec format_expr
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" format_keyword "assert"
format_punctuation "(" format_expr e' format_punctuation ")"
let format_scope
?(debug : bool = false)
(ctx : Dcalc.Ast.decl_ctx)
(fmt : Format.formatter)
((n, s) : Dcalc.Ast.ScopeName.t * Ast.expr Dcalc.Ast.scope_body) : unit =
let format_scope ?(debug = false) ctx fmt (n, s) =
Format.fprintf fmt "@[<hov 2>%a %a =@ %a@]" format_keyword "let"
Dcalc.Ast.ScopeName.format_t n (format_expr ctx ~debug)
(Bindlib.unbox
(Dcalc.Ast.build_whole_scope_expr ~make_abs:Ast.make_abs
~make_let_in:Ast.make_let_in ~box_expr:Ast.box_expr ctx s
(Pos.get_position (Dcalc.Ast.ScopeName.get_info n))))
(Dcalc.Ast.map_mark
(fun _ -> Marked.get_mark (Dcalc.Ast.ScopeName.get_info n))
(fun ty -> ty)
(Dcalc.Ast.get_scope_body_mark s))))

13
compiler/lcalc/print.mli
View File

@ -16,27 +16,22 @@
open Utils
(** {1 Helpers} *)
val is_uppercase : CamomileLibraryDefault.Camomile.UChar.t -> bool
val begins_with_uppercase : string -> bool
(** {1 Formatters} *)
val format_lit : Format.formatter -> Ast.lit Pos.marked -> unit
val format_var : Format.formatter -> Ast.Var.t -> unit
val format_lit : Format.formatter -> Ast.lit Marked.pos -> unit
val format_var : Format.formatter -> 'm Ast.var -> unit
val format_exception : Format.formatter -> Ast.except -> unit
val format_expr :
?debug:bool ->
Dcalc.Ast.decl_ctx ->
Format.formatter ->
Ast.expr Pos.marked ->
'm Ast.marked_expr ->
unit
val format_scope :
?debug:bool ->
Dcalc.Ast.decl_ctx ->
Format.formatter ->
Dcalc.Ast.ScopeName.t * Ast.expr Dcalc.Ast.scope_body ->
Dcalc.Ast.ScopeName.t * ('m Ast.expr, 'm) Dcalc.Ast.scope_body ->
unit

321
compiler/lcalc/to_ocaml.ml
View File

@ -16,11 +16,11 @@
open Utils
open Ast
open Backends
open String_common
module D = Dcalc.Ast
let find_struct (s : D.StructName.t) (ctx : D.decl_ctx) :
(D.StructFieldName.t * D.typ Pos.marked) list =
(D.StructFieldName.t * D.typ Marked.pos) list =
try D.StructMap.find s ctx.D.ctx_structs
with Not_found ->
let s_name, pos = D.StructName.get_info s in
@ -29,7 +29,7 @@ let find_struct (s : D.StructName.t) (ctx : D.decl_ctx) :
s_name
let find_enum (en : D.EnumName.t) (ctx : D.decl_ctx) :
(D.EnumConstructor.t * D.typ Pos.marked) list =
(D.EnumConstructor.t * D.typ Marked.pos) list =
try D.EnumMap.find en ctx.D.ctx_enums
with Not_found ->
let en_name, pos = D.EnumName.get_info en in
@ -37,27 +37,26 @@ let find_enum (en : D.EnumName.t) (ctx : D.decl_ctx) :
"Internal Error: Enumeration %s was not found in the current environment."
en_name
let format_lit (fmt : Format.formatter) (l : lit Pos.marked) : unit =
match Pos.unmark l with
| LBool b ->
Dcalc.Print.format_lit fmt (Pos.same_pos_as (Dcalc.Ast.LBool b) l)
let format_lit (fmt : Format.formatter) (l : lit Marked.pos) : unit =
match Marked.unmark l with
| LBool b -> Dcalc.Print.format_lit fmt (Dcalc.Ast.LBool b)
| LInt i ->
Format.fprintf fmt "integer_of_string@ \"%s\"" (Runtime.integer_to_string i)
| LUnit -> Dcalc.Print.format_lit fmt (Pos.same_pos_as Dcalc.Ast.LUnit l)
| LUnit -> Dcalc.Print.format_lit fmt Dcalc.Ast.LUnit
| LRat i ->
Format.fprintf fmt "decimal_of_string \"%a\"" Dcalc.Print.format_lit
(Pos.same_pos_as (Dcalc.Ast.LRat i) l)
(Dcalc.Ast.LRat i)
| LMoney e ->
Format.fprintf fmt "money_of_cents_string@ \"%s\""
(Runtime.integer_to_string (Runtime.money_to_cents e))
| LDate d ->
Format.fprintf fmt "date_of_numbers %d %d %d"
Format.fprintf fmt "date_of_numbers (%d) (%d) (%d)"
(Runtime.integer_to_int (Runtime.year_of_date d))
(Runtime.integer_to_int (Runtime.month_number_of_date d))
(Runtime.integer_to_int (Runtime.day_of_month_of_date d))
| LDuration d ->
let years, months, days = Runtime.duration_to_years_months_days d in
Format.fprintf fmt "duration_of_numbers %d %d %d" years months days
Format.fprintf fmt "duration_of_numbers (%d) (%d) (%d)" years months days
let format_op_kind (fmt : Format.formatter) (k : Dcalc.Ast.op_kind) =
Format.fprintf fmt "%s"
@ -68,9 +67,9 @@ let format_op_kind (fmt : Format.formatter) (k : Dcalc.Ast.op_kind) =
| KDate -> "@"
| KDuration -> "^")
let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Pos.marked) :
let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Marked.pos) :
unit =
match Pos.unmark op with
match Marked.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
@ -87,9 +86,9 @@ let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Pos.marked) :
| Map -> Format.fprintf fmt "Array.map"
| Filter -> Format.fprintf fmt "array_filter"
let format_ternop (fmt : Format.formatter) (op : Dcalc.Ast.ternop Pos.marked) :
let format_ternop (fmt : Format.formatter) (op : Dcalc.Ast.ternop Marked.pos) :
unit =
match Pos.unmark op with Fold -> Format.fprintf fmt "Array.fold_left"
match Marked.unmark op with Fold -> Format.fprintf fmt "Array.fold_left"
let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list)
: unit =
@ -101,74 +100,80 @@ let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list)
uids
let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
let sanitize_quotes = Re.compile (Re.char '"') in
Format.fprintf fmt "@[<hov 2>[%a]@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt info -> Format.fprintf fmt "\"%s\"" info))
(fun fmt info ->
Format.fprintf fmt "\"%s\""
(Re.replace sanitize_quotes ~f:(fun _ -> "\\\"") info)))
uids
let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Pos.marked) : unit
let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Marked.pos) : unit
=
match Pos.unmark op with
match Marked.unmark op with
| Minus k -> Format.fprintf fmt "~-%a" format_op_kind k
| Not -> Format.fprintf fmt "%s" "not"
| Log (_entry, _infos) ->
Errors.raise_spanned_error (Pos.get_position op)
Errors.raise_spanned_error (Marked.get_mark op)
"Internal error: a log operator has not been caught by the expression \
match"
| Length -> Format.fprintf fmt "%s" "array_length"
| IntToRat -> Format.fprintf fmt "%s" "decimal_of_integer"
| MoneyToRat -> Format.fprintf fmt "%s" "decimal_of_money"
| RatToMoney -> Format.fprintf fmt "%s" "money_of_decimal"
| GetDay -> Format.fprintf fmt "%s" "day_of_month_of_date"
| GetMonth -> Format.fprintf fmt "%s" "month_number_of_date"
| GetYear -> Format.fprintf fmt "%s" "year_of_date"
| FirstDayOfMonth -> Format.fprintf fmt "%s" "first_day_of_month"
| LastDayOfMonth -> Format.fprintf fmt "%s" "last_day_of_month"
| RoundMoney -> Format.fprintf fmt "%s" "money_round"
| RoundDecimal -> Format.fprintf fmt "%s" "decimal_round"
let avoid_keywords (s : string) : string =
if
match s with
(* list taken from
http://caml.inria.fr/pub/docs/manual-ocaml/lex.html#sss:keywords *)
| "and" | "as" | "assert" | "asr" | "begin" | "class" | "constraint" | "do"
| "done" | "downto" | "else" | "end" | "exception" | "external" | "false"
| "for" | "fun" | "function" | "functor" | "if" | "in" | "include"
| "inherit" | "initializer" | "land" | "lazy" | "let" | "lor" | "lsl"
| "lsr" | "lxor" | "match" | "method" | "mod" | "module" | "mutable" | "new"
| "nonrec" | "object" | "of" | "open" | "or" | "private" | "rec" | "sig"
| "struct" | "then" | "to" | "true" | "try" | "type" | "val" | "virtual"
| "when" | "while" | "with" ->
true
| _ -> false
then s ^ "_"
else s
match s with
(* list taken from
http://caml.inria.fr/pub/docs/manual-ocaml/lex.html#sss:keywords *)
| "and" | "as" | "assert" | "asr" | "begin" | "class" | "constraint" | "do"
| "done" | "downto" | "else" | "end" | "exception" | "external" | "false"
| "for" | "fun" | "function" | "functor" | "if" | "in" | "include" | "inherit"
| "initializer" | "land" | "lazy" | "let" | "lor" | "lsl" | "lsr" | "lxor"
| "match" | "method" | "mod" | "module" | "mutable" | "new" | "nonrec"
| "object" | "of" | "open" | "or" | "private" | "rec" | "sig" | "struct"
| "then" | "to" | "true" | "try" | "type" | "val" | "virtual" | "when"
| "while" | "with" ->
s ^ "_user"
| _ -> s
let format_struct_name (fmt : Format.formatter) (v : Dcalc.Ast.StructName.t) :
unit =
Format.asprintf "%a" Dcalc.Ast.StructName.format_t v
|> to_ascii
|> to_lowercase
|> avoid_keywords
|> Format.fprintf fmt "%s"
[@@ocamlformat "disable"]
let format_to_struct_type (fmt : Format.formatter) (v : Dcalc.Ast.StructName.t) :
unit =
Format.asprintf "%a" Dcalc.Ast.StructName.format_t v
|> to_ascii
|> to_lowercase
|> to_snake_case
|> avoid_keywords
|> Format.fprintf fmt "%s"
let format_to_module_name
(fmt : Format.formatter)
(name : [< `Ename of D.EnumName.t | `Sname of D.StructName.t ]) =
(match name with
| `Ename v -> Format.asprintf "%a" D.EnumName.format_t v
| `Sname v -> Format.asprintf "%a" D.StructName.format_t v)
|> to_ascii
|> to_snake_case
|> avoid_keywords
|> String.split_on_char '_'
|> List.map String.capitalize_ascii
|> String.concat ""
|> Format.fprintf fmt "%s"
[@@ocamlformat "disable"]
let format_struct_field_name
(fmt : Format.formatter)
((sname_opt, v) :
Dcalc.Ast.StructName.t option * Dcalc.Ast.StructFieldName.t) : unit =
(match sname_opt with
| Some sname -> Format.fprintf fmt "%a.%s" format_to_struct_type sname
| Some sname ->
Format.fprintf fmt "%a.%s" format_to_module_name (`Sname sname)
| None -> Format.fprintf fmt "%s")
(avoid_keywords
(to_ascii (Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v)))
@ -177,7 +182,7 @@ let format_enum_name (fmt : Format.formatter) (v : Dcalc.Ast.EnumName.t) : unit
=
Format.fprintf fmt "%s"
(avoid_keywords
(to_lowercase
(to_snake_case
(to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumName.format_t v))))
let format_enum_cons_name
@ -187,9 +192,9 @@ let format_enum_cons_name
(avoid_keywords
(to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumConstructor.format_t v)))
let rec typ_embedding_name (fmt : Format.formatter) (ty : D.typ Pos.marked) :
let rec typ_embedding_name (fmt : Format.formatter) (ty : D.typ Marked.pos) :
unit =
match Pos.unmark ty with
match Marked.unmark ty with
| D.TLit D.TUnit -> Format.fprintf fmt "embed_unit"
| D.TLit D.TBool -> Format.fprintf fmt "embed_bool"
| D.TLit D.TInt -> Format.fprintf fmt "embed_integer"
@ -203,19 +208,18 @@ let rec typ_embedding_name (fmt : Format.formatter) (ty : D.typ Pos.marked) :
| D.TArray ty -> Format.fprintf fmt "embed_array (%a)" typ_embedding_name ty
| _ -> Format.fprintf fmt "unembeddable"
let typ_needs_parens (e : Dcalc.Ast.typ Pos.marked) : bool =
match Pos.unmark e with TArrow _ | TArray _ -> true | _ -> false
let typ_needs_parens (e : Dcalc.Ast.typ Marked.pos) : bool =
match Marked.unmark e with TArrow _ | TArray _ -> true | _ -> false
let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Pos.marked) :
let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Marked.pos) :
unit =
let format_typ = format_typ in
let format_typ_with_parens
(fmt : Format.formatter)
(t : Dcalc.Ast.typ Pos.marked) =
(t : Dcalc.Ast.typ Marked.pos) =
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
match Marked.unmark typ with
| TLit l -> Format.fprintf fmt "%a" Dcalc.Print.format_tlit l
| TTuple (ts, None) ->
Format.fprintf fmt "@[<hov 2>(%a)@]"
@ -223,23 +227,24 @@ let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Pos.marked) :
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ *@ ")
format_typ_with_parens)
ts
| TTuple (_, Some s) -> Format.fprintf fmt "%a.t" format_to_struct_type s
| TTuple (_, Some s) ->
Format.fprintf fmt "%a.t" format_to_module_name (`Sname s)
| TEnum ([t], e) when D.EnumName.compare e Ast.option_enum = 0 ->
Format.fprintf fmt "@[<hov 2>(%a)@] %a" format_typ_with_parens t
format_enum_name e
| TEnum (_, e) when D.EnumName.compare e Ast.option_enum = 0 ->
Errors.raise_spanned_error (Pos.get_position typ)
Errors.raise_spanned_error (Marked.get_mark typ)
"Internal Error: found an typing parameter for an eoption type of the \
wrong lenght."
| TEnum (_ts, e) -> Format.fprintf fmt "%a" format_enum_name e
wrong length."
| TEnum (_ts, e) -> Format.fprintf fmt "%a.t" format_to_module_name (`Ename e)
| TArrow (t1, t2) ->
Format.fprintf fmt "@[<hov 2>%a ->@ %a@]" format_typ_with_parens t1
format_typ_with_parens t2
| TArray t1 -> Format.fprintf fmt "@[%a@ array@]" format_typ_with_parens t1
| TAny -> Format.fprintf fmt "_"
let format_var (fmt : Format.formatter) (v : Var.t) : unit =
let lowercase_name = to_lowercase (to_ascii (Bindlib.name_of v)) in
let format_var (fmt : Format.formatter) (v : 'm var) : unit =
let lowercase_name = to_snake_case (to_ascii (Bindlib.name_of v)) in
let lowercase_name =
Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.")
~subst:(fun _ -> "_dot_")
@ -248,26 +253,35 @@ let format_var (fmt : Format.formatter) (v : Var.t) : unit =
let lowercase_name = avoid_keywords (to_ascii lowercase_name) in
if
List.mem lowercase_name ["handle_default"; "handle_default_opt"]
|| Dcalc.Print.begins_with_uppercase (Bindlib.name_of v)
|| begins_with_uppercase (Bindlib.name_of v)
then Format.fprintf fmt "%s" lowercase_name
else if lowercase_name = "_" then Format.fprintf fmt "%s" lowercase_name
else Format.fprintf fmt "%s_" lowercase_name
else (
Cli.debug_print "lowercase_name: %s " lowercase_name;
Format.fprintf fmt "%s_" lowercase_name)
let needs_parens (e : expr Pos.marked) : bool =
match Pos.unmark e with
let needs_parens (e : 'm marked_expr) : bool =
match Marked.unmark e with
| EApp ((EAbs (_, _), _), _)
| ELit (LBool _ | LUnit)
| EVar _ | ETuple _ | EOp _ ->
false
| _ -> true
let format_exception (fmt : Format.formatter) (exc : except Pos.marked) : unit =
match Pos.unmark exc with
| ConflictError -> Format.fprintf fmt "ConflictError"
let format_exception (fmt : Format.formatter) (exc : except Marked.pos) : unit =
match Marked.unmark exc with
| ConflictError ->
let pos = Marked.get_mark exc in
Format.fprintf fmt
"(ConflictError@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ \
start_column=%d;@ end_line=%d; end_column=%d;@ law_headings=%a}@])"
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
(Pos.get_law_info pos)
| EmptyError -> Format.fprintf fmt "EmptyError"
| Crash -> Format.fprintf fmt "Crash"
| NoValueProvided ->
let pos = Pos.get_position exc in
let pos = Marked.get_mark exc in
Format.fprintf fmt
"(NoValueProvided@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ \
start_column=%d;@ end_line=%d; end_column=%d;@ law_headings=%a}@])"
@ -278,14 +292,14 @@ let format_exception (fmt : Format.formatter) (exc : except Pos.marked) : unit =
let rec format_expr
(ctx : Dcalc.Ast.decl_ctx)
(fmt : Format.formatter)
(e : expr Pos.marked) : unit =
(e : 'm marked_expr) : unit =
let format_expr = format_expr ctx in
let format_with_parens (fmt : Format.formatter) (e : expr Pos.marked) =
let format_with_parens (fmt : Format.formatter) (e : 'm marked_expr) =
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)
match Marked.unmark e with
| EVar v -> Format.fprintf fmt "%a" format_var v
| ETuple (es, None) ->
Format.fprintf fmt "@[<hov 2>(%a)@]"
(Format.pp_print_list
@ -321,20 +335,23 @@ let rec format_expr
Format.fprintf fmt "%a.%a" format_with_parens e1 format_struct_field_name
(Some s, fst (List.nth (find_struct s ctx) n)))
| EInj (e, n, en, _ts) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_enum_cons_name
Format.fprintf fmt "@[<hov 2>%a.%a@ %a@]" format_to_module_name (`Ename en)
format_enum_cons_name
(fst (List.nth (find_enum en ctx) n))
format_with_parens e
| EMatch (e, es, e_name) ->
Format.fprintf fmt "@[<hov 2>match@ %a@]@ with@\n%a" format_with_parens e
Format.fprintf fmt "@[<hv>@[<hov 2>match@ %a@]@ with@\n| %a@]"
format_with_parens e
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n| ")
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ | ")
(fun fmt (e, c) ->
Format.fprintf fmt "%a %a" format_enum_cons_name c
Format.fprintf fmt "@[<hov 2>%a.%a %a@]" format_to_module_name
(`Ename e_name) format_enum_cons_name c
(fun fmt e ->
match Pos.unmark e with
| EAbs ((binder, _), _) ->
match Marked.unmark e with
| EAbs (binder, _) ->
let xs, body = Bindlib.unmbind binder in
Format.fprintf fmt "%a ->@[<hov 2>@ %a@]"
Format.fprintf fmt "%a ->@ %a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@,")
(fun fmt x -> Format.fprintf fmt "%a" format_var x))
@ -343,8 +360,8 @@ let rec format_expr
(* should not happen *))
e))
(List.combine es (List.map fst (find_enum e_name ctx)))
| ELit l -> Format.fprintf fmt "%a" format_lit (Pos.same_pos_as l e)
| EApp ((EAbs ((binder, _), taus), _), args) ->
| ELit l -> Format.fprintf fmt "%a" format_lit (Marked.mark (D.pos e) l)
| 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
@ -355,7 +372,7 @@ let rec format_expr
Format.fprintf fmt "@[<hov 2>let@ %a@ :@ %a@ =@ %a@]@ in@\n"
format_var x format_typ tau format_with_parens arg))
xs_tau_arg format_with_parens body
| EAbs ((binder, _), taus) ->
| EAbs (binder, taus) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> x, tau) (Array.to_list xs) taus in
Format.fprintf fmt "@[<hov 2>fun@ %a ->@ %a@]"
@ -380,8 +397,9 @@ let rec format_expr
when !Cli.trace_flag ->
Format.fprintf fmt "(log_variable_definition@ %a@ (%a)@ %a)" format_uid_list
info typ_embedding_name (tau, Pos.no_pos) format_with_parens arg1
| EApp ((EOp (Unop (D.Log (D.PosRecordIfTrueBool, _))), pos), [arg1])
| EApp ((EOp (Unop (D.Log (D.PosRecordIfTrueBool, _))), m), [arg1])
when !Cli.trace_flag ->
let pos = D.mark_pos m in
Format.fprintf fmt
"(log_decision_taken@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ \
start_column=%d;@ end_line=%d; end_column=%d;@ law_headings=%a}@]@ %a)"
@ -397,6 +415,24 @@ let rec format_expr
| EApp ((EOp (Unop op), _), [arg1]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_unop (op, Pos.no_pos)
format_with_parens arg1
| EApp ((EVar x, pos), args)
when Ast.Var.compare (Ast.Var.t x) Ast.handle_default = 0
|| Ast.Var.compare (Ast.Var.t x) Ast.handle_default_opt = 0 ->
Format.fprintf fmt
"@[<hov 2>%a@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ \
start_column=%d;@ end_line=%d; end_column=%d;@ law_headings=%a}@]@ %a@]"
format_var x
(Pos.get_file (D.mark_pos pos))
(Pos.get_start_line (D.mark_pos pos))
(Pos.get_start_column (D.mark_pos pos))
(Pos.get_end_line (D.mark_pos pos))
(Pos.get_end_column (D.mark_pos pos))
format_string_list
(Pos.get_law_info (D.mark_pos pos))
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
format_with_parens)
args
| EApp (f, args) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_with_parens f
(Format.pp_print_list
@ -412,29 +448,38 @@ let rec format_expr
| EOp (Unop op) -> Format.fprintf fmt "%a" format_unop (op, Pos.no_pos)
| EAssert e' ->
Format.fprintf fmt
"@[<hov 2>if @ %a@ then@ ()@ else@ raise AssertionFailed@]"
"@[<hov 2>if@ %a@ then@ ()@ else@ raise (AssertionFailed @[<hov \
2>{filename = \"%s\";@ start_line=%d;@ start_column=%d;@ end_line=%d; \
end_column=%d;@ law_headings=%a}@])@]"
format_with_parens e'
| ERaise exc ->
Format.fprintf fmt "raise@ %a" format_exception (exc, Pos.get_position e)
(Pos.get_file (D.pos e'))
(Pos.get_start_line (D.pos e'))
(Pos.get_start_column (D.pos e'))
(Pos.get_end_line (D.pos e'))
(Pos.get_end_column (D.pos e'))
format_string_list
(Pos.get_law_info (D.pos e'))
| ERaise exc -> Format.fprintf fmt "raise@ %a" format_exception (exc, D.pos e)
| ECatch (e1, exc, e2) ->
Format.fprintf fmt "@[<hov 2>try@ %a@ with@ %a@ ->@ %a@]" format_with_parens
e1 format_exception
(exc, Pos.get_position e)
Format.fprintf fmt
"@,@[<hv>@[<hov 2>try@ %a@]@ with@]@ @[<hov 2>%a@ ->@ %a@]"
format_with_parens e1 format_exception
(exc, D.pos e)
format_with_parens e2
let format_struct_embedding
(fmt : Format.formatter)
((struct_name, struct_fields) :
D.StructName.t * (D.StructFieldName.t * D.typ Pos.marked) list) =
D.StructName.t * (D.StructFieldName.t * D.typ Marked.pos) list) =
if List.length struct_fields = 0 then
Format.fprintf fmt "let embed_%a (_: %a.t) : runtime_value = Unit@\n@\n"
format_struct_name struct_name format_to_struct_type struct_name
format_struct_name struct_name format_to_module_name (`Sname struct_name)
else
Format.fprintf fmt
"@[<hov 2>let embed_%a (x: %a.t) : runtime_value =@ Struct([\"%a\"],@ \
@[<hov 2>[%a]@])@]@\n\
@\n"
format_struct_name struct_name format_to_struct_type struct_name
format_struct_name struct_name format_to_module_name (`Sname struct_name)
D.StructName.format_t struct_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n")
@ -448,17 +493,17 @@ let format_struct_embedding
let format_enum_embedding
(fmt : Format.formatter)
((enum_name, enum_cases) :
D.EnumName.t * (D.EnumConstructor.t * D.typ Pos.marked) list) =
D.EnumName.t * (D.EnumConstructor.t * D.typ Marked.pos) list) =
if List.length enum_cases = 0 then
Format.fprintf fmt "let embed_%a (_: %a) : runtime_value = Unit@\n@\n"
format_enum_name enum_name format_enum_name enum_name
Format.fprintf fmt "let embed_%a (_: %a.t) : runtime_value = Unit@\n@\n"
format_to_module_name (`Ename enum_name) format_enum_name enum_name
else
Format.fprintf fmt
"@[<hov 2>let embed_%a (x: %a) : runtime_value =@ Enum([\"%a\"],@ @[<hov \
2>match x with@ %a@])@]@\n\
"@[<hv 2>@[<hov 2>let embed_%a@ @[<hov 2>(x:@ %a.t)@]@ : runtime_value \
=@]@ Enum([\"%a\"],@ @[<hov 2>match x with@ %a@])@]@\n\
@\n"
format_enum_name enum_name format_enum_name enum_name D.EnumName.format_t
enum_name
format_enum_name enum_name format_to_module_name (`Ename enum_name)
D.EnumName.format_t enum_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (enum_cons, enum_cons_type) ->
@ -474,37 +519,33 @@ let format_ctx
let format_struct_decl fmt (struct_name, struct_fields) =
if List.length struct_fields = 0 then
Format.fprintf fmt
"module %a = struct@\n@[<hov 2>@ type t = unit\nend@] @\n"
format_to_struct_type struct_name
"@[<v 2>module %a = struct@\n@[<hov 2>type t = unit@]@]@\nend@\n"
format_to_module_name (`Sname struct_name)
else
Format.fprintf fmt
"module %a = struct@\n\
@[<hov 2>@ type t = {@\n\
@[<hov 2> %a@]@\n\
}\n\
end@]@\n"
format_to_struct_type struct_name
"@[<v>@[<v 2>module %a = struct@ @[<hv 2>type t = {@,\
%a@;\
<0-2>}@]@]@ end@]@\n"
format_to_module_name (`Sname struct_name)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun _fmt (struct_field, struct_field_type) ->
Format.fprintf fmt "%a:@ %a;" format_struct_field_name
Format.fprintf fmt "@[<hov 2>%a:@ %a@]" format_struct_field_name
(None, struct_field) format_typ struct_field_type))
struct_fields;
if !Cli.trace_flag then
format_struct_embedding fmt (struct_name, struct_fields)
in
let format_enum_decl fmt (enum_name, enum_cons) =
if List.length enum_cons = 0 then
Format.fprintf fmt "type %a = unit@\n@\n" format_enum_name enum_name
else
Format.fprintf fmt "type %a =@\n@[<hov 2> %a@]@\n@\n" format_enum_name
enum_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (enum_cons, enum_cons_type) ->
Format.fprintf fmt "| %a@ of@ %a" format_enum_cons_name enum_cons
format_typ enum_cons_type))
enum_cons;
Format.fprintf fmt
"module %a = struct@\n@[<hov 2>@ type t =@\n@[<hov 2> %a@]@\nend@]@\n"
format_to_module_name (`Ename enum_name)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (enum_cons, enum_cons_type) ->
Format.fprintf fmt "@[<hov 2>| %a@ of@ %a@]" format_enum_cons_name
enum_cons format_typ enum_cons_type))
enum_cons;
if !Cli.trace_flag then format_enum_embedding fmt (enum_name, enum_cons)
in
let is_in_type_ordering s =
@ -535,7 +576,7 @@ let format_ctx
let rec format_scope_body_expr
(ctx : Dcalc.Ast.decl_ctx)
(fmt : Format.formatter)
(scope_lets : Ast.expr Dcalc.Ast.scope_body_expr) : unit =
(scope_lets : ('m Ast.expr, 'm) Dcalc.Ast.scope_body_expr) : unit =
match scope_lets with
| Dcalc.Ast.Result e -> format_expr ctx fmt e
| Dcalc.Ast.ScopeLet scope_let ->
@ -551,7 +592,7 @@ let rec format_scope_body_expr
let rec format_scopes
(ctx : Dcalc.Ast.decl_ctx)
(fmt : Format.formatter)
(scopes : Ast.expr Dcalc.Ast.scopes) : unit =
(scopes : ('m Ast.expr, 'm) Dcalc.Ast.scopes) : unit =
match scopes with
| Dcalc.Ast.Nil -> ()
| Dcalc.Ast.ScopeDef scope_def ->
@ -560,23 +601,27 @@ let rec format_scopes
in
let scope_var, scope_next = Bindlib.unbind scope_def.scope_next in
Format.fprintf fmt "@\n@\n@[<hov 2>let %a (%a: %a.t) : %a.t =@\n%a@]%a"
format_var scope_var format_var scope_input_var format_to_struct_type
scope_def.scope_body.scope_body_input_struct format_to_struct_type
scope_def.scope_body.scope_body_output_struct
format_var scope_var format_var scope_input_var format_to_module_name
(`Sname scope_def.scope_body.scope_body_input_struct)
format_to_module_name
(`Sname scope_def.scope_body.scope_body_output_struct)
(format_scope_body_expr ctx)
scope_body_expr (format_scopes ctx) scope_next
let format_program
(fmt : Format.formatter)
(p : Ast.program)
(p : 'm Ast.program)
(type_ordering : Scopelang.Dependency.TVertex.t list) : unit =
Cli.style_flag := false;
Format.fprintf fmt
"(** This file has been generated by the Catala compiler, do not edit! *)@\n\
@\n\
open Runtime@\n\
@\n\
[@@@@@@ocaml.warning \"-4-26-27-32-41-42\"]@\n\
@\n\
%a%a@?"
(format_ctx type_ordering) p.decl_ctx (format_scopes p.decl_ctx) p.scopes
Cli.call_unstyled (fun _ ->
Format.fprintf fmt
"(** This file has been generated by the Catala compiler, do not edit! \
*)@\n\
@\n\
open Runtime_ocaml.Runtime@\n\
@\n\
[@@@@@@ocaml.warning \"-4-26-27-32-41-42\"]@\n\
@\n\
%a%a@\n\
@?"
(format_ctx type_ordering) p.decl_ctx (format_scopes p.decl_ctx)
p.scopes)

43
compiler/lcalc/to_ocaml.mli
View File

@ -14,8 +14,49 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Ast
(** Formats a lambda calculus program into a valid OCaml program *)
val avoid_keywords : string -> string
val find_struct :
Dcalc.Ast.StructName.t ->
Dcalc.Ast.decl_ctx ->
(Dcalc.Ast.StructFieldName.t * Dcalc.Ast.typ Marked.pos) list
val find_enum :
Dcalc.Ast.EnumName.t ->
Dcalc.Ast.decl_ctx ->
(Dcalc.Ast.EnumConstructor.t * Dcalc.Ast.typ Marked.pos) list
val typ_needs_parens : Dcalc.Ast.typ Marked.pos -> bool
val needs_parens : 'm marked_expr -> bool
val format_enum_name : Format.formatter -> Dcalc.Ast.EnumName.t -> unit
val format_enum_cons_name :
Format.formatter -> Dcalc.Ast.EnumConstructor.t -> unit
val format_struct_name : Format.formatter -> Dcalc.Ast.StructName.t -> unit
val format_struct_field_name :
Format.formatter ->
Dcalc.Ast.StructName.t option * Dcalc.Ast.StructFieldName.t ->
unit
val format_to_module_name :
Format.formatter ->
[< `Ename of Dcalc.Ast.EnumName.t | `Sname of Dcalc.Ast.StructName.t ] ->
unit
val format_lit : Format.formatter -> lit Marked.pos -> unit
val format_uid_list : Format.formatter -> Uid.MarkedString.info list -> unit
val format_var : Format.formatter -> 'm var -> unit
val format_program :
Format.formatter -> Ast.program -> Scopelang.Dependency.TVertex.t list -> unit
Format.formatter ->
'm Ast.program ->
Scopelang.Dependency.TVertex.t list ->
unit
(** Usage [format_program fmt p type_dependencies_ordering] *)

2
compiler/literate/dune
View File

@ -1,7 +1,7 @@
(library
(name literate)
(public_name catala.literate)
(libraries re utils surface))
(libraries re utils surface ubase))
(documentation
(package catala)

117
compiler/literate/html.ml
View File

@ -114,14 +114,14 @@ let wrap_html
(** 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) : string
let pygmentize_code (c : string Marked.pos) (language : C.backend_lang) : string
=
C.debug_print "Pygmenting the code chunk %s"
(Pos.to_string (Pos.get_position c));
(Pos.to_string (Marked.get_mark c));
let temp_file_in = Filename.temp_file "catala_html_pygments" "in" in
let temp_file_out = Filename.temp_file "catala_html_pygments" "out" in
let oc = open_out temp_file_in in
Printf.fprintf oc "%s" (Pos.unmark c);
Printf.fprintf oc "%s" (Marked.unmark c);
close_out oc;
let pygments = "pygmentize" in
let pygments_lexer = get_language_extension language in
@ -133,9 +133,9 @@ let pygmentize_code (c : string Pos.marked) (language : C.backend_lang) : string
"html";
"-O";
"style=colorful,anchorlinenos=True,lineanchors=\""
^ Pos.get_file (Pos.get_position c)
^ String_common.to_ascii (Pos.get_file (Marked.get_mark c))
^ "\",linenos=table,linenostart="
^ string_of_int (Pos.get_start_line (Pos.get_position c) - 1);
^ string_of_int (Pos.get_start_line (Marked.get_mark c) - 1);
"-o";
temp_file_out;
temp_file_in;
@ -158,9 +158,15 @@ let pygmentize_code (c : string Pos.marked) (language : C.backend_lang) : string
(** {1 Weaving} *)
let sanitize_html_href str =
str
|> String_common.to_ascii
|> R.substitute ~rex:(R.regexp "[' '°]") ~subst:(function _ -> "%20")
let rec law_structure_to_html
(language : C.backend_lang)
(print_only_law : bool)
(parents_headings : string list)
(fmt : Format.formatter)
(i : A.law_structure) : unit =
match i with
@ -171,30 +177,83 @@ let rec law_structure_to_html
Format.fprintf fmt
"<div class='code-wrapper%s'>\n<div class='filename'>%s</div>\n%s\n</div>"
(if metadata then " code-metadata" else "")
(Pos.get_file (Pos.get_position c))
(Pos.get_file (Marked.get_mark c))
(pygmentize_code
(Pos.same_pos_as ("```catala\n" ^ Pos.unmark c ^ "```") c)
(Marked.same_mark_as ("```catala\n" ^ Marked.unmark c ^ "```") c)
language)
| A.CodeBlock _ -> ()
| A.LawHeading (heading, children) ->
let h_number = heading.law_heading_precedence + 1 in
Format.fprintf fmt "<h%d class='law-heading'><a href='%s'>%s</a></h%d>\n"
h_number
let is_a_section_to_collapse =
(* Only 2 depth sections are collasped in a <details> tag. Indeed, this
allow to significantly reduce rendering time (~= 100x for the
[aides_logement] example in the catala-website), while remaining
practicable. *)
h_number = 2
in
let h_name = Marked.unmark heading.law_heading_name in
let complete_headings = parents_headings @ [h_name] in
let id = complete_headings |> String.concat "-" |> sanitize_html_href in
let fmt_details_open fmt () =
if is_a_section_to_collapse then
Format.fprintf fmt "<details><summary>%s</summary>" h_name
in
let fmt_details_close fmt () =
if is_a_section_to_collapse then Format.fprintf fmt "</details>"
in
Format.fprintf fmt
"<h%d class='law-heading' id=\"%s\"><a href=\"#%s\">%s</a>%s</h%d>@\n\
%a\n\
%a\n\
%a"
h_number id id h_name
(match heading.law_heading_id, language with
| Some id, Fr ->
let ltime = Unix.localtime (Unix.time ()) in
P.sprintf "https://legifrance.gouv.fr/codes/id/%s/%d-%02d-%02d" id
P.sprintf
"<a class=\"link-article\" \
href=\"https://legifrance.gouv.fr/codes/id/%s/%d-%02d-%02d\" \
target=\"_blank\">Voir le texte sur Légifrance.gouv.fr</a>"
id
(1900 + ltime.Unix.tm_year)
(ltime.Unix.tm_mon + 1) ltime.Unix.tm_mday
| _ -> "#")
(pre_html (Pos.unmark heading.law_heading_name))
h_number;
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n")
(law_structure_to_html language print_only_law)
fmt children
| _ -> "")
h_number fmt_details_open ()
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n")
(law_structure_to_html language print_only_law complete_headings))
children fmt_details_close ()
| A.LawInclude _ -> ()
let rec fmt_toc
(parents_headings : string list)
fmt
(items : A.law_structure list) =
Format.fprintf fmt "@[<v 2><ol class=\"toc-%d\">@\n%a@\n@]</ol>"
(List.length parents_headings)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt item ->
match item with
| A.LawHeading (heading, childs) ->
let h_name = Marked.unmark heading.law_heading_name in
let complete_headings = parents_headings @ [h_name] in
let id =
complete_headings |> String.concat "-" |> sanitize_html_href
in
Format.fprintf fmt
"@[<hov 2><li class=\"toc-item\">@\n\
@[<hov 2><div>@\n\
<a href=\"#%s\">%s</a>@\n\
%a@\n\
@]</div>@\n\
@]</li>"
id h_name
(fmt_toc complete_headings)
childs
| _ -> ()))
(items |> List.filter (function A.LawHeading (_, _) -> true | _ -> false))
(** {1 API} *)
let ast_to_html
@ -202,7 +261,23 @@ let ast_to_html
~(print_only_law : bool)
(fmt : Format.formatter)
(program : A.program) : unit =
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(law_structure_to_html language print_only_law)
fmt program.program_items
let toc =
match language with
| C.Fr -> "Sommaire"
| C.En -> "Table of contents"
| C.Pl -> "Spis treści."
in
Format.fprintf fmt
"@[<hov 2><details class=\"toc\">@\n\
<summary>%s</summary>@\n\
%a@\n\
@]</details>\n\
%a@\n"
toc (fmt_toc []) program.program_items
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(fun fmt ->
Format.fprintf fmt "%a"
(law_structure_to_html language print_only_law [])))
program.program_items

19
compiler/literate/latex.ml
View File

@ -182,9 +182,10 @@ let check_exceeding_lines
(start_line : int)
(filename : string)
(content : string) =
content |> String.split_on_char '\n'
content
|> String.split_on_char '\n'
|> List.iteri (fun i s ->
if CamomileLibrary.UTF8.length s > max_len then (
if String.length s > max_len then (
Cli.warning_print "The line %s in %s is exceeding %s characters:"
(Cli.with_style
ANSITerminal.[Bold; yellow]
@ -216,7 +217,7 @@ let rec law_structure_to_latex
| 6 -> "subsubsubsubsubsubsection"
| 7 -> "paragraph"
| _ -> "subparagraph")
(pre_latexify (Pos.unmark heading.law_heading_name));
(pre_latexify (Marked.unmark heading.law_heading_name));
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(law_structure_to_latex language print_only_law)
@ -241,10 +242,10 @@ let rec law_structure_to_latex
```catala\n\
%s```\n\
\\end{minted}"
(pre_latexify (Filename.basename (Pos.get_file (Pos.get_position c))))
(Pos.get_start_line (Pos.get_position c) - 1)
(pre_latexify (Filename.basename (Pos.get_file (Marked.get_mark c))))
(Pos.get_start_line (Marked.get_mark c) - 1)
(get_language_extension language)
(Pos.unmark c)
(Marked.unmark c)
| A.CodeBlock (_, c, true) when not print_only_law ->
let metadata_title =
match language with
@ -252,9 +253,9 @@ let rec law_structure_to_latex
| En -> "Metadata"
| Pl -> "Metadane"
in
let start_line = Pos.get_start_line (Pos.get_position c) - 1 in
let filename = Filename.basename (Pos.get_file (Pos.get_position c)) in
let block_content = Pos.unmark c in
let start_line = Pos.get_start_line (Marked.get_mark c) - 1 in
let filename = Filename.basename (Pos.get_file (Marked.get_mark c)) in
let block_content = Marked.unmark c in
check_exceeding_lines start_line filename block_content;
Format.fprintf fmt
"\\begin{tcolorbox}[colframe=OliveGreen, breakable, \

3
compiler/literate/literate_common.ml
View File

@ -78,7 +78,8 @@ let run_pandoc (s : string) (backend : [ `Html | `Latex ]) : string =
let pandoc_args =
[|
"-f";
"markdown+multiline_tables";
"markdown+multiline_tables+tex_math_dollars";
"--mathjax";
"-t";
(match backend with `Html -> "html" | `Latex -> "latex");
"-o";

14
compiler/plugin.ml
View File

@ -14,13 +14,23 @@
License for the specific language governing permissions and limitations under
the License. *)
type 'ast plugin_apply_fun_typ =
source_file:Utils.Pos.input_file ->
output_file:string option ->
scope:string option ->
'ast ->
Scopelang.Dependency.TVertex.t list ->
unit
type 'ast gen = {
name : string;
extension : string;
apply : string option -> 'ast -> Scopelang.Dependency.TVertex.t list -> unit;
apply : 'ast plugin_apply_fun_typ;
}
type t = Lcalc of Lcalc.Ast.program gen | Scalc of Scalc.Ast.program gen
type t =
| Lcalc of Dcalc.Ast.untyped Lcalc.Ast.program gen
| Scalc of Scalc.Ast.program gen
let name = function Lcalc { name; _ } | Scalc { name; _ } -> name
let backend_plugins : (string, t) Hashtbl.t = Hashtbl.create 17

24
compiler/plugin.mli
View File

@ -16,13 +16,23 @@
(** {2 catala-facing API} *)
type 'ast plugin_apply_fun_typ =
source_file:Utils.Pos.input_file ->
output_file:string option ->
scope:string option ->
'ast ->
Scopelang.Dependency.TVertex.t list ->
unit
type 'ast gen = {
name : string;
extension : string;
apply : string option -> 'ast -> Scopelang.Dependency.TVertex.t list -> unit;
apply : 'ast plugin_apply_fun_typ;
}
type t = Lcalc of Lcalc.Ast.program gen | Scalc of Scalc.Ast.program gen
type t =
| Lcalc of Dcalc.Ast.untyped Lcalc.Ast.program gen
| Scalc of Scalc.Ast.program gen
val find : string -> t
(** Find a registered plugin *)
@ -39,19 +49,13 @@ module PluginAPI : sig
val register_lcalc :
name:string ->
extension:string ->
(string option ->
Lcalc.Ast.program ->
Scopelang.Dependency.TVertex.t list ->
unit) ->
Dcalc.Ast.untyped Lcalc.Ast.program plugin_apply_fun_typ ->
unit
val register_scalc :
name:string ->
extension:string ->
(string option ->
Scalc.Ast.program ->
Scopelang.Dependency.TVertex.t list ->
unit) ->
Scalc.Ast.program plugin_apply_fun_typ ->
unit
end

473
compiler/plugins/api_web.ml Normal file
View File

@ -0,0 +1,473 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria,
contributors: Emile Rolley <emile.rolley@tuta.io>, Louis Gesbert
<louis.gesbert@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. *)
(** Catala plugin for generating web APIs. It generates OCaml code before the
the associated [js_of_ocaml] wrapper. *)
open Utils
open String_common
open Lcalc
open Lcalc.Ast
open Lcalc.To_ocaml
module D = Dcalc.Ast
let name = "api_web"
let extension = ".ml"
(** Contains all format functions used to generating the [js_of_ocaml] wrapper
of the corresponding Catala program. *)
module To_jsoo = struct
let to_camel_case (s : string) : string =
String.split_on_char '_' s
|> (function
| hd :: tl -> hd :: List.map String.capitalize_ascii tl | l -> l)
|> String.concat ""
let format_struct_field_name_camel_case
(fmt : Format.formatter)
(v : Dcalc.Ast.StructFieldName.t) : unit =
let s =
Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v
|> to_ascii
|> to_snake_case
|> avoid_keywords
|> to_camel_case
in
Format.fprintf fmt "%s" s
let format_tlit (fmt : Format.formatter) (l : Dcalc.Ast.typ_lit) : unit =
Dcalc.Print.format_base_type fmt
(match l with
| TUnit -> "unit"
| TInt -> "int"
| TRat | TMoney -> "Js.number Js.t"
| TDuration -> "Runtime_jsoo.Runtime.duration Js.t"
| TBool -> "bool Js.t"
| TDate -> "Js.js_string Js.t")
let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Marked.pos) :
unit =
let format_typ_with_parens
(fmt : Format.formatter)
(t : Dcalc.Ast.typ Marked.pos) =
if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t
else Format.fprintf fmt "%a" format_typ t
in
match Marked.unmark typ with
| TLit l -> Format.fprintf fmt "%a" format_tlit l
| TTuple (_, Some s) -> Format.fprintf fmt "%a Js.t" format_struct_name s
| TTuple (_, None) ->
(* Tuples are encoded as an javascript polymorphic array. *)
Format.fprintf fmt "Js.Unsafe.any_js_array Js.t "
| TEnum ([t], e) when D.EnumName.compare e option_enum = 0 ->
Format.fprintf fmt "@[<hov 2>(%a)@] %a" format_typ_with_parens t
format_enum_name e
| TEnum (_, e) when D.EnumName.compare e option_enum = 0 ->
Errors.raise_spanned_error (Marked.get_mark typ)
"Internal Error: found an typing parameter for an eoption type of the \
wrong length."
| TEnum (_, e) -> Format.fprintf fmt "%a Js.t" format_enum_name e
| TArray t1 ->
Format.fprintf fmt "@[%a@ Js.js_array Js.t@]" format_typ_with_parens t1
| TAny -> Format.fprintf fmt "Js.Unsafe.any Js.t"
| TArrow (t1, t2) ->
Format.fprintf fmt "(@[<hov 2>%a, @ %a@]) Js.meth_callback"
format_typ_with_parens t1 format_typ_with_parens t2
let rec format_typ_to_jsoo fmt typ =
match Marked.unmark typ with
| Dcalc.Ast.TLit TBool -> Format.fprintf fmt "Js.bool"
| Dcalc.Ast.TLit TInt -> Format.fprintf fmt "integer_to_int"
| Dcalc.Ast.TLit TRat ->
Format.fprintf fmt "Js.number_of_float %@%@ decimal_to_float"
| Dcalc.Ast.TLit TMoney ->
Format.fprintf fmt "Js.number_of_float %@%@ money_to_float"
| Dcalc.Ast.TLit TDuration -> Format.fprintf fmt "duration_to_jsoo"
| Dcalc.Ast.TLit TDate -> Format.fprintf fmt "date_to_jsoo"
| Dcalc.Ast.TEnum (_, ename) ->
Format.fprintf fmt "%a_to_jsoo" format_enum_name ename
| Dcalc.Ast.TTuple (_, Some sname) ->
Format.fprintf fmt "%a_to_jsoo" format_struct_name sname
| Dcalc.Ast.TArray t ->
Format.fprintf fmt "Js.array %@%@ Array.map (fun x -> %a x)"
format_typ_to_jsoo t
| Dcalc.Ast.TAny | Dcalc.Ast.TTuple (_, None) ->
Format.fprintf fmt "Js.Unsafe.inject"
| _ -> Format.fprintf fmt ""
let rec format_typ_of_jsoo fmt typ =
match Marked.unmark typ with
| Dcalc.Ast.TLit TBool -> Format.fprintf fmt "Js.to_bool"
| Dcalc.Ast.TLit TInt -> Format.fprintf fmt "integer_of_int"
| Dcalc.Ast.TLit TRat ->
Format.fprintf fmt "decimal_of_float %@%@ Js.float_of_number"
| Dcalc.Ast.TLit TMoney ->
Format.fprintf fmt
"money_of_decimal %@%@ decimal_of_float %@%@ Js.float_of_number"
| Dcalc.Ast.TLit TDuration -> Format.fprintf fmt "duration_of_jsoo"
| Dcalc.Ast.TLit TDate -> Format.fprintf fmt "date_of_jsoo"
| Dcalc.Ast.TEnum (_, ename) ->
Format.fprintf fmt "%a_of_jsoo" format_enum_name ename
| Dcalc.Ast.TTuple (_, Some sname) ->
Format.fprintf fmt "%a_of_jsoo" format_struct_name sname
| Dcalc.Ast.TArray t ->
Format.fprintf fmt "Array.map (fun x -> %a x) %@%@ Js.to_array"
format_typ_of_jsoo t
| _ -> Format.fprintf fmt ""
let format_var_camel_case (fmt : Format.formatter) (v : 'm var) : unit =
let lowercase_name =
Bindlib.name_of v
|> to_ascii
|> to_snake_case
|> Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.") ~subst:(fun _ ->
"_dot_")
|> to_ascii
|> avoid_keywords
|> to_camel_case
in
if
List.mem lowercase_name ["handle_default"; "handle_default_opt"]
|| begins_with_uppercase (Bindlib.name_of v)
then Format.fprintf fmt "%s" lowercase_name
else if lowercase_name = "_" then Format.fprintf fmt "%s" lowercase_name
else Format.fprintf fmt "%s_" lowercase_name
let format_ctx
(type_ordering : Scopelang.Dependency.TVertex.t list)
(fmt : Format.formatter)
(ctx : D.decl_ctx) : unit =
let format_prop_or_meth fmt (struct_field_type : D.typ Marked.pos) =
match Marked.unmark struct_field_type with
| Dcalc.Ast.TArrow _ -> Format.fprintf fmt "Js.meth"
| _ -> Format.fprintf fmt "Js.readonly_prop"
in
let format_struct_decl fmt (struct_name, struct_fields) =
let fmt_struct_name fmt _ = format_struct_name fmt struct_name in
let fmt_module_struct_name fmt _ =
To_ocaml.format_to_module_name fmt (`Sname struct_name)
in
let fmt_to_jsoo fmt _ =
Format.fprintf fmt "%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (struct_field, struct_field_type) ->
match Marked.unmark struct_field_type with
| Dcalc.Ast.TArrow (t1, t2) ->
Format.fprintf fmt
"@[<hov 2>method %a =@ Js.wrap_meth_callback@ @[<hv 2>(@,\
fun input ->@ %a (%a.%a (%a input)))@]@]"
format_struct_field_name_camel_case struct_field
format_typ_to_jsoo t2 fmt_struct_name ()
format_struct_field_name (None, struct_field)
format_typ_of_jsoo t1
| _ ->
Format.fprintf fmt "@[<hov 2>val %a =@ %a %a.%a@]"
format_struct_field_name_camel_case struct_field
format_typ_to_jsoo struct_field_type fmt_struct_name ()
format_struct_field_name (None, struct_field)))
struct_fields
in
let fmt_of_jsoo fmt _ =
Format.fprintf fmt "%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n")
(fun fmt (struct_field, struct_field_type) ->
match Marked.unmark struct_field_type with
| Dcalc.Ast.TArrow _ ->
Format.fprintf fmt
"%a = failwith \"The function '%a' translation isn't yet \
supported...\""
format_struct_field_name (None, struct_field)
format_struct_field_name (None, struct_field)
| _ ->
Format.fprintf fmt
"@[<hv 2>%a =@ @[<hov 2>%a@ @[<hov>%a@,##.%a@]@]@]"
format_struct_field_name (None, struct_field)
format_typ_of_jsoo struct_field_type fmt_struct_name ()
format_struct_field_name_camel_case struct_field))
struct_fields
in
let fmt_conv_funs fmt _ =
Format.fprintf fmt
"@[<hov 2>let %a_to_jsoo@ (%a@ : %a.t)@ : %a Js.t =@ @[<hv \
2>object%%js@\n\
%a@\n\
@]@]end@\n\
@[<hov 2>let %a_of_jsoo@ @[<hov 2>(%a@ : %a Js.t)@] :@ %a.t =@ \
@[<hv 2>{@,\
%a@]@\n\
}@]"
fmt_struct_name () fmt_struct_name () fmt_module_struct_name ()
fmt_struct_name () fmt_to_jsoo () fmt_struct_name () fmt_struct_name
() fmt_struct_name () fmt_module_struct_name () fmt_of_jsoo ()
in
if List.length struct_fields = 0 then
Format.fprintf fmt
"class type %a =@ object end@\n\
let %a_to_jsoo (_ : %a.t) : %a Js.t = object%%js end@\n\
let %a_of_jsoo (_ : %a Js.t) : %a.t = ()" fmt_struct_name ()
fmt_struct_name () fmt_module_struct_name () fmt_struct_name ()
fmt_struct_name () fmt_struct_name () fmt_module_struct_name ()
else
Format.fprintf fmt
"@[<hv 2>class type %a =@ @[<hov 2>object@ %a@]@,end@\n%a@]@\n"
fmt_struct_name ()
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (struct_field, struct_field_type) ->
Format.fprintf fmt "@[<hov 2>method %a:@ %a %a@]"
format_struct_field_name_camel_case struct_field format_typ
struct_field_type format_prop_or_meth struct_field_type))
struct_fields fmt_conv_funs ()
in
let format_enum_decl
fmt
(enum_name, (enum_cons : (D.EnumConstructor.t * D.typ Marked.pos) list))
=
let fmt_enum_name fmt _ = format_enum_name fmt enum_name in
let fmt_module_enum_name fmt _ =
To_ocaml.format_to_module_name fmt (`Ename enum_name)
in
let fmt_to_jsoo fmt _ =
Format.fprintf fmt "%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (cname, typ) ->
match Marked.unmark typ with
| Dcalc.Ast.TTuple (_, None) ->
Cli.error_print
"Tuples aren't supported yet in the conversion to JS"
| _ ->
Format.fprintf fmt
"@[<v 2>@[<v 4>| %a arg -> object%%js@\n\
val kind = Js.string \"%a\"@\n\
val payload = Js.Unsafe.coerce (Js.Unsafe.inject (%a \
arg))@]@\n\
end@]"
format_enum_cons_name cname format_enum_cons_name cname
format_typ_to_jsoo typ))
enum_cons
in
let fmt_of_jsoo fmt _ =
Format.fprintf fmt
"@[<hov 2>match@ %a##.kind@ |> Js.to_string@ with@]@\n\
@[<hv>%a@\n\
@[<hv 2>| cons ->@ @[<hov 2>failwith@ @[<hov 2>(Printf.sprintf@ \
\"Unexpected '%%s' kind for the enumeration '%a.t'\"@ cons)@]@]@]@]"
fmt_enum_name ()
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (cname, typ) ->
match Marked.unmark typ with
| Dcalc.Ast.TTuple (_, None) ->
Cli.error_print
"Tuples aren't yet supported in the conversion to JS..."
| Dcalc.Ast.TLit TUnit ->
Format.fprintf fmt "@[<hv 2>| \"%a\" ->@ %a.%a ()@]"
format_enum_cons_name cname fmt_module_enum_name ()
format_enum_cons_name cname
| _ ->
Format.fprintf fmt
"| \"%a\" ->@\n%a.%a (%a (Js.Unsafe.coerce %a##.payload))"
format_enum_cons_name cname fmt_module_enum_name ()
format_enum_cons_name cname format_typ_of_jsoo typ
fmt_enum_name ()))
enum_cons fmt_module_enum_name ()
in
let fmt_conv_funs fmt _ =
Format.fprintf fmt
"@[<hov 2>let %a_to_jsoo@ : %a.t -> %a Js.t@ = function@\n\
%a@]@\n\
@\n\
@[<hov 2>let %a_of_jsoo@ @[<hov 2>(%a@ : %a Js.t)@]@ : %a.t =@ %a@]@\n"
fmt_enum_name () fmt_module_enum_name () fmt_enum_name () fmt_to_jsoo
() fmt_enum_name () fmt_enum_name () fmt_enum_name ()
fmt_module_enum_name () fmt_of_jsoo ()
in
Format.fprintf fmt
"@[<v 2>class type %a =@ @[<v 2>object@ @[<hov 2>method kind :@ \
Js.js_string Js.t Js.readonly_prop@\n\
@[<v 2>(** Expects one of:@\n\
%a *)@]@]@\n\
@\n\
@[<hov 2>method payload :@ Js.Unsafe.any Js.t Js.readonly_prop@]@]@\n\
end@]@\n\
@\n\
%a@\n"
format_enum_name enum_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (enum_cons, _) ->
Format.fprintf fmt "- \"%a\"" format_enum_cons_name enum_cons))
enum_cons fmt_conv_funs ()
in
let is_in_type_ordering s =
List.exists
(fun struct_or_enum ->
match struct_or_enum with
| Scopelang.Dependency.TVertex.Enum _ -> false
| Scopelang.Dependency.TVertex.Struct s' -> s = s')
type_ordering
in
let scope_structs =
List.map
(fun (s, _) -> Scopelang.Dependency.TVertex.Struct s)
(Dcalc.Ast.StructMap.bindings
(Dcalc.Ast.StructMap.filter
(fun s _ -> not (is_in_type_ordering s))
ctx.ctx_structs))
in
List.iter
(fun struct_or_enum ->
match struct_or_enum with
| Scopelang.Dependency.TVertex.Struct s ->
Format.fprintf fmt "%a@\n" format_struct_decl (s, find_struct s ctx)
| Scopelang.Dependency.TVertex.Enum e ->
Format.fprintf fmt "%a@\n" format_enum_decl (e, find_enum e ctx))
(type_ordering @ scope_structs)
let fmt_input_struct_name fmt (scope_def : ('a expr, 'm) D.scope_def) =
format_struct_name fmt scope_def.scope_body.scope_body_input_struct
let fmt_output_struct_name fmt (scope_def : ('a expr, 'm) D.scope_def) =
format_struct_name fmt scope_def.scope_body.scope_body_output_struct
let rec format_scopes_to_fun
(ctx : Dcalc.Ast.decl_ctx)
(fmt : Format.formatter)
(scopes : ('expr, 'm) Dcalc.Ast.scopes) =
match scopes with
| Dcalc.Ast.Nil -> ()
| Dcalc.Ast.ScopeDef scope_def ->
let scope_var, scope_next = Bindlib.unbind scope_def.scope_next in
let fmt_fun_call fmt _ =
Format.fprintf fmt "@[<hv>%a@ |> %a_of_jsoo@ |> %a@ |> %a_to_jsoo@]"
fmt_input_struct_name scope_def fmt_input_struct_name scope_def
format_var scope_var fmt_output_struct_name scope_def
in
Format.fprintf fmt
"@\n@\n@[<hov 2>let %a@ (%a : %a Js.t)@ : %a Js.t =@\n%a@]@\n%a"
format_var scope_var fmt_input_struct_name scope_def
fmt_input_struct_name scope_def fmt_output_struct_name scope_def
fmt_fun_call () (format_scopes_to_fun ctx) scope_next
let rec format_scopes_to_callbacks
(ctx : Dcalc.Ast.decl_ctx)
(fmt : Format.formatter)
(scopes : ('expr, 'm) Dcalc.Ast.scopes) : unit =
match scopes with
| Dcalc.Ast.Nil -> ()
| Dcalc.Ast.ScopeDef scope_def ->
let scope_var, scope_next = Bindlib.unbind scope_def.scope_next in
let fmt_meth_name fmt _ =
Format.fprintf fmt "method %a : (%a Js.t -> %a Js.t) Js.callback"
format_var_camel_case scope_var fmt_input_struct_name scope_def
fmt_output_struct_name scope_def
in
Format.fprintf fmt "@,@[<hov 2>%a =@ Js.wrap_callback@ %a@]@,%a"
fmt_meth_name () format_var scope_var
(format_scopes_to_callbacks ctx)
scope_next
let format_program
(fmt : Format.formatter)
(module_name : string option)
(prgm : 'm Lcalc.Ast.program)
(type_ordering : Scopelang.Dependency.TVertex.t list) =
let fmt_lib_name fmt _ =
Format.fprintf fmt "%sLib"
(Option.fold ~none:""
~some:(fun name ->
List.nth (String.split_on_char ' ' name) 1
|> String.split_on_char '_'
|> List.map String.capitalize_ascii
|> String.concat "")
module_name)
in
Cli.call_unstyled (fun _ ->
Format.fprintf fmt
"(** This file has been generated by the Catala compiler, do not \
edit! *)@\n\
@\n\
open Runtime_ocaml.Runtime@\n\
open Runtime_jsoo.Runtime@\n\
open Js_of_ocaml@\n\
%s@\n\
@\n\
[@@@@@@ocaml.warning \"-4-26-27-32-41-42\"]@\n\
@\n\
(* Generated API *)@\n\
@\n\
%a@\n\
%a@\n\
@\n\
@[<v 2>let _ =@ @[<hov 2> Js.export \"%a\"@\n\
@[<v 2>(object%%js@ %a@]@\n\
end)@]@]@?"
(Option.fold ~none:"" ~some:(fun name -> name) module_name)
(format_ctx type_ordering) prgm.decl_ctx
(format_scopes_to_fun prgm.decl_ctx)
prgm.scopes fmt_lib_name ()
(format_scopes_to_callbacks prgm.decl_ctx)
prgm.scopes)
end
let apply
~(source_file : Pos.input_file)
~(output_file : string option)
~scope
(prgm : 'm Lcalc.Ast.program)
(type_ordering : Scopelang.Dependency.TVertex.t list) =
ignore scope;
File.with_formatter_of_opt_file output_file (fun fmt ->
Cli.trace_flag := true;
Cli.debug_print "Writing OCaml code to %s..."
(Option.value ~default:"stdout" output_file);
To_ocaml.format_program fmt prgm type_ordering);
let output_file, filename_without_ext =
match output_file with
| Some "-" -> output_file, output_file
| Some f ->
output_file, Some (Filename.basename f |> Filename.remove_extension)
| None -> Some "-", None
in
let jsoo_output_file, with_formatter =
File.get_formatter_of_out_channel ~source_file
~output_file:
(Option.map
(fun name ->
if "-" = name then "-"
else Filename.remove_extension name ^ "_api_web.ml")
output_file)
~ext:"_api_web.ml" ()
in
let module_name =
Option.map
(fun name -> Printf.sprintf "open %s" (String.capitalize_ascii name))
filename_without_ext
in
with_formatter (fun fmt ->
Cli.debug_print "Writing JSOO API code to %s..."
(Option.value ~default:"stdout" jsoo_output_file);
To_jsoo.format_program fmt module_name prgm type_ordering)
let () = Driver.Plugin.register_lcalc ~name ~extension apply

12
compiler/plugins/dune
View File

@ -5,10 +5,16 @@
(libraries catala.driver))
(executable
(name jsoo)
(name api_web)
(modes plugin)
(modules jsoo)
(libraries catala.driver catala.runtime))
(modules api_web)
(libraries catala.driver))
(executable
(name json_schema)
(modes plugin)
(modules json_schema)
(libraries catala.driver))
(documentation
(package catala)

244
compiler/plugins/json_schema.ml Normal file
View File

@ -0,0 +1,244 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria,
contributors: Emile Rolley <emile.rolley@tuta.io>.
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
(** Catala plugin for generating {{:https://json-schema.org} JSON schemas} used
to build forms for the Catala website. *)
let name = "json_schema"
let extension = "_schema.json"
open Utils
open String_common
open Lcalc.Ast
open Lcalc.To_ocaml
module D = Dcalc.Ast
(** Contains all format functions used to format a Lcalc Catala program
representation to a JSON schema describing the corresponding web form. *)
module To_json = struct
let to_camel_case (s : string) : string =
String.split_on_char '_' s
|> (function
| hd :: tl -> hd :: List.map String.capitalize_ascii tl | l -> l)
|> String.concat ""
let format_struct_field_name_camel_case
(fmt : Format.formatter)
(v : Dcalc.Ast.StructFieldName.t) : unit =
let s =
Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v
|> to_ascii
|> to_snake_case
|> avoid_keywords
|> to_camel_case
in
Format.fprintf fmt "%s" s
let rec find_scope_def (target_name : string) :
('m expr, 'm) D.scopes -> ('m expr, 'm) D.scope_def option = function
| D.Nil -> None
| D.ScopeDef scope_def ->
let name =
Format.asprintf "%a" D.ScopeName.format_t scope_def.scope_name
in
if name = target_name then Some scope_def
else
let _, next_scope = Bindlib.unbind scope_def.scope_next in
find_scope_def target_name next_scope
let fmt_tlit fmt (tlit : D.typ_lit) =
match tlit with
| TUnit -> Format.fprintf fmt "\"type\": \"null\",@\n\"default\": null"
| TInt | TRat -> Format.fprintf fmt "\"type\": \"number\",@\n\"default\": 0"
| TMoney ->
Format.fprintf fmt
"\"type\": \"number\",@\n\"minimum\": 0,@\n\"default\": 0"
| TBool -> Format.fprintf fmt "\"type\": \"boolean\",@\n\"default\": false"
| TDate -> Format.fprintf fmt "\"type\": \"string\",@\n\"format\": \"date\""
| TDuration -> failwith "TODO: tlit duration"
let rec fmt_type fmt (typ : D.marked_typ) =
match Marked.unmark typ with
| D.TLit tlit -> fmt_tlit fmt tlit
| D.TTuple (_, Some sname) ->
Format.fprintf fmt "\"$ref\": \"#/definitions/%a\"" format_struct_name
sname
| D.TEnum (_, ename) ->
Format.fprintf fmt "\"$ref\": \"#/definitions/%a\"" format_enum_name ename
| D.TArray t ->
Format.fprintf fmt
"\"type\": \"array\",@\n\
\"default\": [],@\n\
@[<hov 2>\"items\": {@\n\
%a@]@\n\
}"
fmt_type t
| _ -> ()
let fmt_struct_properties
(ctx : D.decl_ctx)
(fmt : Format.formatter)
(sname : D.StructName.t) =
Format.fprintf fmt "%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
(fun fmt (field_name, field_type) ->
Format.fprintf fmt "@[<hov 2>\"%a\": {@\n%a@]@\n}"
format_struct_field_name_camel_case field_name fmt_type field_type))
(find_struct sname ctx)
let fmt_definitions
(ctx : D.decl_ctx)
(fmt : Format.formatter)
(scope_def : ('m expr, 'm) D.scope_def) =
let get_name t =
match Marked.unmark t with
| D.TTuple (_, Some sname) ->
Format.asprintf "%a" format_struct_name sname
| D.TEnum (_, ename) -> Format.asprintf "%a" format_enum_name ename
| _ -> failwith "unreachable: only structs and enums are collected."
in
let rec collect_required_type_defs_from_scope_input
(input_struct : D.StructName.t) : D.marked_typ list =
let rec collect (acc : D.marked_typ list) (t : D.marked_typ) :
D.marked_typ list =
match Marked.unmark t with
| D.TTuple (_, Some s) ->
(* Scope's input is a struct. *)
(t :: acc) @ collect_required_type_defs_from_scope_input s
| D.TEnum (ts, _) -> List.fold_left collect (t :: acc) ts
| D.TArray t -> collect acc t
| _ -> acc
in
find_struct input_struct ctx
|> List.fold_left (fun acc (_, field_typ) -> collect acc field_typ) []
|> List.sort_uniq (fun t t' -> String.compare (get_name t) (get_name t'))
in
let fmt_enum_properties fmt ename =
let enum_def = find_enum ename ctx in
Format.fprintf fmt
"@[<hov 2>\"kind\": {@\n\
\"type\": \"string\",@\n\
@[<hov 2>\"anyOf\": [@\n\
%a@]@\n\
]@]@\n\
}@\n\
},@\n\
@[<hov 2>\"allOf\": [@\n\
%a@]@\n\
]@]@\n\
}"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
(fun fmt (enum_cons, _) ->
Format.fprintf fmt
"@[<hov 2>{@\n\"type\": \"string\",@\n\"enum\": [\"%a\"]@]@\n}"
format_enum_cons_name enum_cons))
enum_def
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
(fun fmt (enum_cons, payload_type) ->
Format.fprintf fmt
"@[<hov 2>{@\n\
@[<hov 2>\"if\": {@\n\
@[<hov 2>\"properties\": {@\n\
@[<hov 2>\"kind\": {@\n\
\"const\": \"%a\"@]@\n\
}@]@\n\
}@]@\n\
},@\n\
@[<hov 2>\"then\": {@\n\
@[<hov 2>\"properties\": {@\n\
@[<hov 2>\"payload\": {@\n\
%a@]@\n\
}@]@\n\
}@]@\n\
}@]@\n\
}"
format_enum_cons_name enum_cons fmt_type payload_type))
enum_def
in
Format.fprintf fmt "@\n%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
(fun fmt typ ->
match Marked.unmark typ with
| D.TTuple (_, Some sname) ->
Format.fprintf fmt
"@[<hov 2>\"%a\": {@\n\
\"type\": \"object\",@\n\
@[<hov 2>\"properties\": {@\n\
%a@]@\n\
}@]@\n\
}"
format_struct_name sname
(fmt_struct_properties ctx)
sname
| D.TEnum (_, ename) ->
Format.fprintf fmt
"@[<hov 2>\"%a\": {@\n\
\"type\": \"object\",@\n\
@[<hov 2>\"properties\": {@\n\
%a@]@]@\n"
format_enum_name ename fmt_enum_properties ename
| _ -> ()))
(collect_required_type_defs_from_scope_input
scope_def.scope_body.scope_body_input_struct)
let format_program
(fmt : Format.formatter)
(scope : string)
(prgm : 'm Lcalc.Ast.program) =
match find_scope_def scope prgm.scopes with
| None -> Cli.error_print "Internal error: scope '%s' not found." scope
| Some scope_def ->
Cli.call_unstyled (fun _ ->
Format.fprintf fmt
"{@[<hov 2>@\n\
\"type\": \"object\",@\n\
\"@[<hov 2>definitions\": {%a@]@\n\
},@\n\
\"@[<hov 2>properties\": {@\n\
%a@]@\n\
}@]@\n\
}"
(fmt_definitions prgm.decl_ctx)
scope_def
(fmt_struct_properties prgm.decl_ctx)
scope_def.scope_body.scope_body_input_struct)
end
let apply
~(source_file : Pos.input_file)
~(output_file : string option)
~(scope : string option)
(prgm : 'm Lcalc.Ast.program)
(type_ordering : Scopelang.Dependency.TVertex.t list) =
ignore source_file;
ignore type_ordering;
match scope with
| Some s ->
File.with_formatter_of_opt_file output_file (fun fmt ->
Cli.debug_print
"Writing JSON schema corresponding to the scope '%s' to the file \
%s..."
s
(Option.value ~default:"stdout" output_file);
To_json.format_program fmt s prgm)
| None -> Cli.error_print "A scope must be specified for the plugin: %s" name
let () = Driver.Plugin.register_lcalc ~name ~extension apply

78
compiler/plugins/jsoo.ml
View File

@ -1,78 +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:
Louis Gesbert <louis.gesbert@inria.fr>.
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
(** This file demonstrates the use of backend plugins for Catala. It's a simple
wrapper on top of the OCaml backend that calls js_of_ocaml on the generated
code. Not for production use. *)
let name = "jsoo"
let extension = ".js"
let finalise e f =
let bt = Printexc.get_raw_backtrace () in
f ();
Printexc.raise_with_backtrace e bt
let finally f k =
match k () with
| r ->
f ();
r
| exception e -> finalise e f
let with_open_out file f =
let oc = open_out file in
finally (fun () -> close_out oc) (fun () -> f oc)
let with_temp_file pfx sfx f =
let tmp = Filename.temp_file pfx sfx in
match f tmp with
| r ->
Sys.remove tmp;
r
| exception e ->
let bt = Printexc.get_raw_backtrace () in
Sys.remove tmp;
Printexc.raise_with_backtrace e bt
let apply output_file prgm type_ordering =
with_temp_file "catala_jsoo_" ".ml" @@ fun ml_file ->
Utils.File.with_formatter_of_opt_file output_file @@ fun fmt ->
Lcalc.To_ocaml.format_program fmt prgm type_ordering;
with_temp_file "catala_jsoo_" ".byte" @@ fun bytecode_file ->
if
Sys.command
(Printf.sprintf
"ocamlfind ocamlc -package catala.runtime -linkpkg %S -o %S" ml_file
bytecode_file)
<> 0
then failwith "ocaml err";
Utils.Cli.debug_print "OCaml compil ok";
let out_arg =
match output_file with Some f -> Printf.sprintf "%S" f | None -> "-"
in
if
Sys.command
(Printf.sprintf
"js_of_ocaml +zarith_stubs_js/biginteger.js \
+zarith_stubs_js/runtime.js %S -o %s"
bytecode_file out_arg)
<> 0
then failwith "jsoo err";
Utils.Cli.debug_print "Jsoo compil ok, output in %s"
(Option.value ~default:"stdout" output_file)
let () = Driver.Plugin.register_lcalc ~name ~extension apply

26
compiler/plugins/plugins.mld
View File

@ -41,11 +41,25 @@ This trivial example registers a plugin that uses the [scalc] format as input.
It simply calls the code of the built-in Python backend, and should be no
different to using the normal Catala Python output mode.
{2 jsoo example}
{2 [js_of_ocaml] wrapper generator example}
This slightly more involved plugin reads the [lcalc] format, applies the code of
the [OCaml] backend normally, but then calls the [ocamlc] and [js_of_ocaml]
compiler successively on the output in order to give a Javascript output.
This plugin generates a [js_of_ocaml] wrapper from the [lcalc] representation
of a Catala program.
Note that this output remains a library, it won't provide user-facing features,
and no efforts are made to make it callable from normal JavaScript code.
It start by generating the OCaml module before generating the [_api_web.ml]
one, which contains all the class types and conversion functions between the
OCaml types and their corresponding JS objects. At the end the module exposes
all methods in a JS lib [<module_name>Lib].
See
{{:https://github.com/CatalaLang/catala/tree/master/french_law/ocaml/law_source}
law_source} for examples of generated code.
{2 JSON schema generator example}
This plugin generates a {{:https://json-schema.org} JSON schema} corresponding
to a scope of a Catala program.
See
{{:https://github.com/CatalaLang/catala/tree/master/french_law/json_schemas}
json_schemas} for examples of generated schemas.

8
compiler/plugins/python.ml
View File

@ -23,8 +23,10 @@
let name = "python-plugin"
let extension = ".py"
let apply output_file prgm type_ordering =
Utils.File.with_formatter_of_opt_file output_file @@ fun fmt ->
Scalc.To_python.format_program fmt prgm type_ordering
let apply ~source_file ~output_file ~scope prgm type_ordering =
ignore source_file;
ignore scope;
Utils.File.with_formatter_of_opt_file output_file
@@ fun fmt -> Scalc.To_python.format_program fmt prgm type_ordering
let () = Driver.Plugin.register_scalc ~name ~extension apply

28
compiler/scalc/ast.ml
View File

@ -20,26 +20,30 @@ module L = Lcalc.Ast
module TopLevelName = Uid.Make (Uid.MarkedString) ()
module LocalName = Uid.Make (Uid.MarkedString) ()
let dead_value = LocalName.fresh ("dead_value", Pos.no_pos)
let handle_default = TopLevelName.fresh ("handle_default", Pos.no_pos)
let handle_default_opt = TopLevelName.fresh ("handle_default_opt", Pos.no_pos)
type expr =
| EVar of LocalName.t
| EFunc of TopLevelName.t
| EStruct of expr Pos.marked list * D.StructName.t
| EStructFieldAccess of expr Pos.marked * D.StructFieldName.t * D.StructName.t
| EInj of expr Pos.marked * D.EnumConstructor.t * D.EnumName.t
| EArray of expr Pos.marked list
| EStruct of expr Marked.pos list * D.StructName.t
| EStructFieldAccess of expr Marked.pos * D.StructFieldName.t * D.StructName.t
| EInj of expr Marked.pos * D.EnumConstructor.t * D.EnumName.t
| EArray of expr Marked.pos list
| ELit of L.lit
| EApp of expr Pos.marked * expr Pos.marked list
| EApp of expr Marked.pos * expr Marked.pos list
| EOp of Dcalc.Ast.operator
type stmt =
| SInnerFuncDef of LocalName.t Pos.marked * func
| SLocalDecl of LocalName.t Pos.marked * D.typ Pos.marked
| SLocalDef of LocalName.t Pos.marked * expr Pos.marked
| SInnerFuncDef of LocalName.t Marked.pos * func
| SLocalDecl of LocalName.t Marked.pos * D.typ Marked.pos
| SLocalDef of LocalName.t Marked.pos * expr Marked.pos
| STryExcept of block * L.except * block
| SRaise of L.except
| SIfThenElse of expr Pos.marked * block * block
| SIfThenElse of expr Marked.pos * block * block
| SSwitch of
expr Pos.marked
expr Marked.pos
* D.EnumName.t
* (block (* Statements corresponding to arm closure body*)
* (* Variable instantiated with enum payload *) LocalName.t)
@ -47,10 +51,10 @@ type stmt =
| SReturn of expr
| SAssert of expr
and block = stmt Pos.marked list
and block = stmt Marked.pos list
and func = {
func_params : (LocalName.t Pos.marked * D.typ Pos.marked) list;
func_params : (LocalName.t Marked.pos * D.typ Marked.pos) list;
func_body : block;
}

148
compiler/scalc/compile_from_lambda.ml
View File

@ -29,15 +29,15 @@ type ctxt = {
(* Expressions can spill out side effect, hence this function also returns a
list of statements to be prepended before the expression is evaluated *)
let rec translate_expr (ctxt : ctxt) (expr : L.expr Pos.marked) :
A.block * A.expr Pos.marked =
match Pos.unmark expr with
let rec translate_expr (ctxt : ctxt) (expr : 'm L.marked_expr) :
A.block * A.expr Marked.pos =
match Marked.unmark expr with
| L.EVar v ->
let local_var =
try A.EVar (L.VarMap.find (Pos.unmark v) ctxt.var_dict)
with Not_found -> A.EFunc (L.VarMap.find (Pos.unmark v) ctxt.func_dict)
try A.EVar (L.VarMap.find (L.Var.t v) ctxt.var_dict)
with Not_found -> A.EFunc (L.VarMap.find (L.Var.t v) ctxt.func_dict)
in
[], (local_var, Pos.get_position v)
[], (local_var, D.pos expr)
| L.ETuple (args, Some s_name) ->
let args_stmts, new_args =
List.fold_left
@ -48,7 +48,7 @@ let rec translate_expr (ctxt : ctxt) (expr : L.expr Pos.marked) :
in
let new_args = List.rev new_args in
let args_stmts = List.rev args_stmts in
args_stmts, (A.EStruct (new_args, s_name), Pos.get_position expr)
args_stmts, (A.EStruct (new_args, s_name), D.pos expr)
| L.ETuple (_, None) ->
failwith "Non-struct tuples cannot be compiled to scalc"
| L.ETupleAccess (e1, num_field, Some s_name, _) ->
@ -57,9 +57,7 @@ let rec translate_expr (ctxt : ctxt) (expr : L.expr Pos.marked) :
fst
(List.nth (D.StructMap.find s_name ctxt.decl_ctx.ctx_structs) num_field)
in
( e1_stmts,
(A.EStructFieldAccess (new_e1, field_name, s_name), Pos.get_position expr)
)
e1_stmts, (A.EStructFieldAccess (new_e1, field_name, s_name), D.pos expr)
| L.ETupleAccess (_, _, None, _) ->
failwith "Non-struct tuples cannot be compiled to scalc"
| L.EInj (e1, num_cons, e_name, _) ->
@ -67,7 +65,7 @@ let rec translate_expr (ctxt : ctxt) (expr : L.expr Pos.marked) :
let cons_name =
fst (List.nth (D.EnumMap.find e_name ctxt.decl_ctx.ctx_enums) num_cons)
in
e1_stmts, (A.EInj (new_e1, cons_name, e_name), Pos.get_position expr)
e1_stmts, (A.EInj (new_e1, cons_name, e_name), D.pos expr)
| L.EApp (f, args) ->
let f_stmts, new_f = translate_expr ctxt f in
let args_stmts, new_args =
@ -78,7 +76,7 @@ let rec translate_expr (ctxt : ctxt) (expr : L.expr Pos.marked) :
([], []) args
in
let new_args = List.rev new_args in
f_stmts @ args_stmts, (A.EApp (new_f, new_args), Pos.get_position expr)
f_stmts @ args_stmts, (A.EApp (new_f, new_args), D.pos expr)
| L.EArray args ->
let args_stmts, new_args =
List.fold_left
@ -88,9 +86,9 @@ let rec translate_expr (ctxt : ctxt) (expr : L.expr Pos.marked) :
([], []) args
in
let new_args = List.rev new_args in
args_stmts, (A.EArray new_args, Pos.get_position expr)
| L.EOp op -> [], (A.EOp op, Pos.get_position expr)
| L.ELit l -> [], (A.ELit l, Pos.get_position expr)
args_stmts, (A.EArray new_args, D.pos expr)
| L.EOp op -> [], (A.EOp op, D.pos expr)
| L.ELit l -> [], (A.ELit l, D.pos expr)
| _ ->
let tmp_var =
A.LocalName.fresh
@ -100,34 +98,33 @@ let rec translate_expr (ctxt : ctxt) (expr : L.expr Pos.marked) :
(match ctxt.inside_definition_of with
| None -> ctxt.context_name
| Some v ->
let v = Pos.unmark (A.LocalName.get_info v) in
let v = Marked.unmark (A.LocalName.get_info v) in
let tmp_rex = Re.Pcre.regexp "^temp_" in
if Re.Pcre.pmatch ~rex:tmp_rex v then v else "temp_" ^ v),
Pos.get_position expr )
D.pos expr )
in
let ctxt =
{
ctxt with
inside_definition_of = Some tmp_var;
context_name = Pos.unmark (A.LocalName.get_info tmp_var);
context_name = Marked.unmark (A.LocalName.get_info tmp_var);
}
in
let tmp_stmts = translate_statements ctxt expr in
( ( A.SLocalDecl
((tmp_var, Pos.get_position expr), (D.TAny, Pos.get_position expr)),
Pos.get_position expr )
( (A.SLocalDecl ((tmp_var, D.pos expr), (D.TAny, D.pos expr)), D.pos expr)
:: tmp_stmts,
(A.EVar tmp_var, Pos.get_position expr) )
(A.EVar tmp_var, D.pos expr) )
and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) :
A.block =
match Pos.unmark block_expr with
and translate_statements (ctxt : ctxt) (block_expr : 'm L.marked_expr) : A.block
=
match Marked.unmark block_expr with
| L.EAssert e ->
(* Assertions are always encapsulated in a unit-typed let binding *)
let e_stmts, new_e = translate_expr ctxt e in
e_stmts @ [A.SAssert (Pos.unmark new_e), Pos.get_position block_expr]
| L.EApp ((L.EAbs ((binder, binder_pos), taus), eabs_pos), args) ->
e_stmts @ [A.SAssert (Marked.unmark new_e), D.pos block_expr]
| L.EApp ((L.EAbs (binder, taus), binder_mark), args) ->
(* This defines multiple local variables at the time *)
let binder_pos = D.mark_pos binder_mark in
let vars, body = Bindlib.unmbind binder in
let vars_tau = List.map2 (fun x tau -> x, tau) (Array.to_list vars) taus in
let ctxt =
@ -136,7 +133,7 @@ and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) :
var_dict =
List.fold_left
(fun var_dict (x, _) ->
L.VarMap.add x
L.VarMap.add (L.Var.t x)
(A.LocalName.fresh (Bindlib.name_of x, binder_pos))
var_dict)
ctxt.var_dict vars_tau;
@ -145,14 +142,15 @@ and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) :
let local_decls =
List.map
(fun (x, tau) ->
( A.SLocalDecl ((L.VarMap.find x ctxt.var_dict, binder_pos), tau),
eabs_pos ))
( A.SLocalDecl
((L.VarMap.find (L.Var.t x) ctxt.var_dict, binder_pos), tau),
binder_pos ))
vars_tau
in
let vars_args =
List.map2
(fun (x, tau) arg ->
(L.VarMap.find x ctxt.var_dict, binder_pos), tau, arg)
(L.VarMap.find (L.Var.t x) ctxt.var_dict, binder_pos), tau, arg)
vars_tau args
in
let def_blocks =
@ -161,8 +159,9 @@ and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) :
let ctxt =
{
ctxt with
inside_definition_of = Some (Pos.unmark x);
context_name = Pos.unmark (A.LocalName.get_info (Pos.unmark x));
inside_definition_of = Some (Marked.unmark x);
context_name =
Marked.unmark (A.LocalName.get_info (Marked.unmark x));
}
in
let arg_stmts, new_arg = translate_expr ctxt arg in
@ -171,13 +170,13 @@ and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) :
in
let rest_of_block = translate_statements ctxt body in
local_decls @ List.flatten def_blocks @ rest_of_block
| L.EAbs ((binder, binder_pos), taus) ->
| L.EAbs (binder, taus) ->
let vars, body = Bindlib.unmbind binder in
let binder_pos = D.pos block_expr in
let vars_tau = List.map2 (fun x tau -> x, tau) (Array.to_list vars) taus in
let closure_name =
match ctxt.inside_definition_of with
| None ->
A.LocalName.fresh (ctxt.context_name, Pos.get_position block_expr)
| None -> A.LocalName.fresh (ctxt.context_name, D.pos block_expr)
| Some x -> x
in
let ctxt =
@ -186,7 +185,7 @@ and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) :
var_dict =
List.fold_left
(fun var_dict (x, _) ->
L.VarMap.add x
L.VarMap.add (L.Var.t x)
(A.LocalName.fresh (Bindlib.name_of x, binder_pos))
var_dict)
ctxt.var_dict vars_tau;
@ -201,7 +200,7 @@ and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) :
func_params =
List.map
(fun (var, tau) ->
(L.VarMap.find var ctxt.var_dict, binder_pos), tau)
(L.VarMap.find (L.Var.t var) ctxt.var_dict, binder_pos), tau)
vars_tau;
func_body = new_body;
} ),
@ -212,16 +211,19 @@ and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) :
let new_args =
List.fold_left
(fun new_args arg ->
match Pos.unmark arg with
| L.EAbs ((binder, pos_binder), _) ->
match Marked.unmark arg with
| L.EAbs (binder, _) ->
let vars, body = Bindlib.unmbind binder in
assert (Array.length vars = 1);
let var = vars.(0) in
let scalc_var =
A.LocalName.fresh (Bindlib.name_of var, pos_binder)
A.LocalName.fresh (Bindlib.name_of var, D.pos arg)
in
let ctxt =
{ ctxt with var_dict = L.VarMap.add var scalc_var ctxt.var_dict }
{
ctxt with
var_dict = L.VarMap.add (L.Var.t var) scalc_var ctxt.var_dict;
}
in
let new_arg = translate_statements ctxt body in
(new_arg, scalc_var) :: new_args
@ -230,19 +232,28 @@ and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) :
[] args
in
let new_args = List.rev new_args in
e1_stmts
@ [A.SSwitch (new_e1, e_name, new_args), Pos.get_position block_expr]
e1_stmts @ [A.SSwitch (new_e1, e_name, new_args), D.pos block_expr]
| L.EIfThenElse (cond, e_true, e_false) ->
let cond_stmts, s_cond = translate_expr ctxt cond in
let s_e_true = translate_statements ctxt e_true in
let s_e_false = translate_statements ctxt e_false in
cond_stmts
@ [A.SIfThenElse (s_cond, s_e_true, s_e_false), Pos.get_position block_expr]
cond_stmts @ [A.SIfThenElse (s_cond, s_e_true, s_e_false), D.pos block_expr]
| L.ECatch (e_try, except, e_catch) ->
let s_e_try = translate_statements ctxt e_try in
let s_e_catch = translate_statements ctxt e_catch in
[A.STryExcept (s_e_try, except, s_e_catch), Pos.get_position block_expr]
| L.ERaise except -> [A.SRaise except, Pos.get_position block_expr]
[A.STryExcept (s_e_try, except, s_e_catch), D.pos block_expr]
| L.ERaise except ->
(* Before raising the exception, we still give a dummy definition to the
current variable so that tools like mypy don't complain. *)
(match ctxt.inside_definition_of with
| None -> []
| Some x ->
[
( A.SLocalDef
((x, D.pos block_expr), (Ast.EVar Ast.dead_value, D.pos block_expr)),
D.pos block_expr );
])
@ [A.SRaise except, D.pos block_expr]
| _ -> (
let e_stmts, new_e = translate_expr ctxt block_expr in
e_stmts
@ -256,9 +267,9 @@ and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) :
| _ ->
[
( (match ctxt.inside_definition_of with
| None -> A.SReturn (Pos.unmark new_e)
| Some x -> A.SLocalDef (Pos.same_pos_as x new_e, new_e)),
Pos.get_position block_expr );
| None -> A.SReturn (Marked.unmark new_e)
| Some x -> A.SLocalDef (Marked.same_mark_as x new_e, new_e)),
D.pos block_expr );
])
let rec translate_scope_body_expr
@ -266,7 +277,7 @@ let rec translate_scope_body_expr
(decl_ctx : D.decl_ctx)
(var_dict : A.LocalName.t L.VarMap.t)
(func_dict : A.TopLevelName.t L.VarMap.t)
(scope_expr : L.expr D.scope_body_expr) : A.block =
(scope_expr : ('m L.expr, 'm) D.scope_body_expr) : A.block =
match scope_expr with
| Result e ->
let block, new_e =
@ -276,17 +287,17 @@ let rec translate_scope_body_expr
func_dict;
var_dict;
inside_definition_of = None;
context_name = Pos.unmark (D.ScopeName.get_info scope_name);
context_name = Marked.unmark (D.ScopeName.get_info scope_name);
}
e
in
block @ [A.SReturn (Pos.unmark new_e), Pos.get_position new_e]
block @ [A.SReturn (Marked.unmark new_e), Marked.get_mark new_e]
| ScopeLet scope_let ->
let let_var, scope_let_next = Bindlib.unbind scope_let.scope_let_next in
let let_var_id =
A.LocalName.fresh (Bindlib.name_of let_var, scope_let.scope_let_pos)
in
let new_var_dict = L.VarMap.add let_var let_var_id var_dict in
let new_var_dict = L.VarMap.add (L.Var.t let_var) let_var_id var_dict in
(match scope_let.scope_let_kind with
| D.Assertion ->
translate_statements
@ -295,7 +306,7 @@ let rec translate_scope_body_expr
func_dict;
var_dict;
inside_definition_of = Some let_var_id;
context_name = Pos.unmark (D.ScopeName.get_info scope_name);
context_name = Marked.unmark (D.ScopeName.get_info scope_name);
}
scope_let.scope_let_expr
| _ ->
@ -306,7 +317,7 @@ let rec translate_scope_body_expr
func_dict;
var_dict;
inside_definition_of = Some let_var_id;
context_name = Pos.unmark (D.ScopeName.get_info scope_name);
context_name = Marked.unmark (D.ScopeName.get_info scope_name);
}
scope_let.scope_let_expr
in
@ -321,9 +332,9 @@ let rec translate_scope_body_expr
@ translate_scope_body_expr scope_name decl_ctx new_var_dict func_dict
scope_let_next
let translate_program (p : L.program) : A.program =
let translate_program (p : 'm L.program) : A.program =
{
decl_ctx = p.L.decl_ctx;
decl_ctx = p.D.decl_ctx;
scopes =
(let _, new_scopes =
D.fold_left_scope_defs
@ -332,13 +343,13 @@ let translate_program (p : L.program) : A.program =
Bindlib.unbind scope_def.scope_body.scope_body_expr
in
let input_pos =
Pos.get_position (D.ScopeName.get_info scope_def.scope_name)
Marked.get_mark (D.ScopeName.get_info scope_def.scope_name)
in
let scope_input_var_id =
A.LocalName.fresh (Bindlib.name_of scope_input_var, input_pos)
in
let var_dict =
L.VarMap.singleton scope_input_var scope_input_var_id
L.VarMap.singleton (L.Var.t scope_input_var) scope_input_var_id
in
let new_scope_body =
translate_scope_body_expr scope_def.D.scope_name p.decl_ctx
@ -347,7 +358,9 @@ let translate_program (p : L.program) : A.program =
let func_id =
A.TopLevelName.fresh (Bindlib.name_of scope_var, Pos.no_pos)
in
let func_dict = L.VarMap.add scope_var func_id func_dict in
let func_dict =
L.VarMap.add (L.Var.t scope_var) func_id func_dict
in
( func_dict,
{
Ast.scope_body_name = scope_def.D.scope_name;
@ -362,7 +375,7 @@ let translate_program (p : L.program) : A.program =
(D.StructMap.find
scope_def.D.scope_body
.D.scope_body_input_struct
p.L.decl_ctx.ctx_structs),
p.D.decl_ctx.ctx_structs),
Some
scope_def.D.scope_body
.D.scope_body_input_struct ),
@ -374,13 +387,10 @@ let translate_program (p : L.program) : A.program =
:: new_scopes ))
~init:
( (if !Cli.avoid_exceptions_flag then
L.VarMap.singleton L.handle_default_opt
(A.TopLevelName.fresh ("handle_default_opt", Pos.no_pos))
else
L.VarMap.singleton L.handle_default
(A.TopLevelName.fresh ("handle_default", Pos.no_pos))),
L.VarMap.singleton L.handle_default_opt A.handle_default_opt
else L.VarMap.singleton L.handle_default A.handle_default),
[] )
p.L.scopes
p.D.scopes
in
List.rev new_scopes);
}

2
compiler/scalc/dune
View File

@ -1,7 +1,7 @@
(library
(name scalc)
(public_name catala.scalc)
(libraries bindlib lcalc runtime))
(libraries bindlib lcalc catala.runtime_ocaml))
(documentation
(package catala)

51
compiler/scalc/print.ml
View File

@ -17,7 +17,7 @@
open Utils
open Ast
let needs_parens (_e : expr Pos.marked) : bool = false
let needs_parens (_e : expr Marked.pos) : bool = false
let format_local_name (fmt : Format.formatter) (v : LocalName.t) : unit =
Format.fprintf fmt "%a_%s" LocalName.format_t v
@ -27,15 +27,15 @@ let rec format_expr
(decl_ctx : Dcalc.Ast.decl_ctx)
?(debug : bool = false)
(fmt : Format.formatter)
(e : expr Pos.marked) : unit =
(e : expr Marked.pos) : unit =
let format_expr = format_expr decl_ctx ~debug in
let format_with_parens (fmt : Format.formatter) (e : expr Pos.marked) =
let format_with_parens (fmt : Format.formatter) (e : expr Marked.pos) =
if needs_parens e then
Format.fprintf fmt "%a%a%a" Dcalc.Print.format_punctuation "(" format_expr
e Dcalc.Print.format_punctuation ")"
else Format.fprintf fmt "%a" format_expr e
in
match Pos.unmark e with
match Marked.unmark e with
| EVar v -> Format.fprintf fmt "%a" format_local_name v
| EFunc v -> Format.fprintf fmt "%a" TopLevelName.format_t v
| EStruct (es, s) ->
@ -75,62 +75,59 @@ let rec format_expr
(Dcalc.Ast.EnumMap.find enum decl_ctx.ctx_enums)))
format_expr e
| ELit l ->
Format.fprintf fmt "%a" Lcalc.Print.format_lit (Pos.same_pos_as l e)
Format.fprintf fmt "%a" Lcalc.Print.format_lit (Marked.same_mark_as l e)
| EApp
((EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), [arg1; arg2])
->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" Dcalc.Print.format_binop
(op, Pos.no_pos) format_with_parens arg1 format_with_parens arg2
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" Dcalc.Print.format_binop op
format_with_parens arg1 format_with_parens arg2
| EApp ((EOp (Binop op), _), [arg1; arg2]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1
Dcalc.Print.format_binop (op, Pos.no_pos) format_with_parens arg2
Dcalc.Print.format_binop op format_with_parens arg2
| EApp ((EOp (Unop (Log _)), _), [arg1]) when not debug ->
Format.fprintf fmt "%a" format_with_parens arg1
| EApp ((EOp (Unop op), _), [arg1]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Dcalc.Print.format_unop
(op, Pos.no_pos) format_with_parens arg1
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Dcalc.Print.format_unop op
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
| 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)
| EOp (Ternop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_ternop op
| EOp (Binop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_binop op
| EOp (Unop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_unop op
let rec format_statement
(decl_ctx : Dcalc.Ast.decl_ctx)
?(debug : bool = false)
(fmt : Format.formatter)
(stmt : stmt Pos.marked) : unit =
(stmt : stmt Marked.pos) : unit =
if debug then () else ();
match Pos.unmark stmt with
match Marked.unmark stmt with
| SInnerFuncDef (name, func) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@]@\n@[<v 2> %a@]"
Dcalc.Print.format_keyword "let" LocalName.format_t (Pos.unmark name)
Dcalc.Print.format_keyword "let" LocalName.format_t (Marked.unmark name)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt ((name, _), typ) ->
Format.fprintf fmt "%a%a %a@ %a%a" Dcalc.Print.format_punctuation "("
LocalName.format_t name Dcalc.Print.format_punctuation ":"
(Dcalc.Print.format_typ decl_ctx)
typ Dcalc.Print.format_punctuation ")"))
(Marked.unmark typ) Dcalc.Print.format_punctuation ")"))
func.func_params Dcalc.Print.format_punctuation "="
(format_block decl_ctx ~debug)
func.func_body
| SLocalDecl (name, typ) ->
Format.fprintf fmt "@[<hov 2>%a %a %a@ %a@]" Dcalc.Print.format_keyword
"decl" LocalName.format_t (Pos.unmark name) Dcalc.Print.format_punctuation
":"
"decl" LocalName.format_t (Marked.unmark name)
Dcalc.Print.format_punctuation ":"
(Dcalc.Print.format_typ decl_ctx)
typ
(Marked.unmark typ)
| SLocalDef (name, expr) ->
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" LocalName.format_t
(Pos.unmark name) Dcalc.Print.format_punctuation "="
(Marked.unmark name) Dcalc.Print.format_punctuation "="
(format_expr decl_ctx ~debug)
expr
| STryExcept (b_try, except, b_with) ->
@ -157,11 +154,11 @@ let rec format_statement
| SReturn ret ->
Format.fprintf fmt "@[<hov 2>%a %a@]" Dcalc.Print.format_keyword "return"
(format_expr decl_ctx ~debug)
(ret, Pos.get_position stmt)
(ret, Marked.get_mark stmt)
| SAssert expr ->
Format.fprintf fmt "@[<hov 2>%a %a@]" Dcalc.Print.format_keyword "assert"
(format_expr decl_ctx ~debug)
(expr, Pos.get_position stmt)
(expr, Marked.get_mark stmt)
| SSwitch (e_switch, enum, arms) ->
Format.fprintf fmt "@[<v 0>%a @[<hov 2>%a@]%a@]%a"
Dcalc.Print.format_keyword "switch"
@ -204,7 +201,7 @@ let format_scope
Format.fprintf fmt "%a%a %a@ %a%a" Dcalc.Print.format_punctuation "("
LocalName.format_t name Dcalc.Print.format_punctuation ":"
(Dcalc.Print.format_typ decl_ctx)
typ Dcalc.Print.format_punctuation ")"))
(Marked.unmark typ) Dcalc.Print.format_punctuation ")"))
body.scope_body_func.func_params Dcalc.Print.format_punctuation "="
(format_block decl_ctx ~debug)
body.scope_body_func.func_body

230
compiler/scalc/to_python.ml
View File

@ -17,12 +17,13 @@
open Utils
open Ast
open Lcalc.Backends
open String_common
module Runtime = Runtime_ocaml.Runtime
module D = Dcalc.Ast
module L = Lcalc.Ast
let format_lit (fmt : Format.formatter) (l : L.lit Pos.marked) : unit =
match Pos.unmark l with
let format_lit (fmt : Format.formatter) (l : L.lit Marked.pos) : unit =
match Marked.unmark l with
| LBool true -> Format.fprintf fmt "True"
| LBool false -> Format.fprintf fmt "False"
| LInt i ->
@ -30,7 +31,7 @@ let format_lit (fmt : Format.formatter) (l : L.lit Pos.marked) : unit =
| LUnit -> Format.fprintf fmt "Unit()"
| LRat i ->
Format.fprintf fmt "decimal_of_string(\"%a\")" Dcalc.Print.format_lit
(Pos.same_pos_as (Dcalc.Ast.LRat i) l)
(Dcalc.Ast.LRat i)
| LMoney e ->
Format.fprintf fmt "money_of_cents_string(\"%s\")"
(Runtime.integer_to_string (Runtime.money_to_cents e))
@ -51,9 +52,9 @@ let format_log_entry (fmt : Format.formatter) (entry : Dcalc.Ast.log_entry) :
| EndCall -> Format.fprintf fmt "%s" "← "
| PosRecordIfTrueBool -> Format.fprintf fmt "☛ "
let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Pos.marked) :
let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Marked.pos) :
unit =
match Pos.unmark op with
match Marked.unmark op with
| Add _ | Concat -> Format.fprintf fmt "+"
| Sub _ -> Format.fprintf fmt "-"
| Mult _ -> Format.fprintf fmt "*"
@ -70,9 +71,9 @@ let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Pos.marked) :
| Map -> Format.fprintf fmt "list_map"
| Filter -> Format.fprintf fmt "list_filter"
let format_ternop (fmt : Format.formatter) (op : Dcalc.Ast.ternop Pos.marked) :
let format_ternop (fmt : Format.formatter) (op : Dcalc.Ast.ternop Marked.pos) :
unit =
match Pos.unmark op with Fold -> Format.fprintf fmt "list_fold_left"
match Marked.unmark op with Fold -> Format.fprintf fmt "list_fold_left"
let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list)
: unit =
@ -84,23 +85,30 @@ let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list)
uids
let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
let sanitize_quotes = Re.compile (Re.char '"') in
Format.fprintf fmt "[%a]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt info -> Format.fprintf fmt "\"%s\"" info))
(fun fmt info ->
Format.fprintf fmt "\"%s\""
(Re.replace sanitize_quotes ~f:(fun _ -> "\\\"") info)))
uids
let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Pos.marked) : unit
let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Marked.pos) : unit
=
match Pos.unmark op with
match Marked.unmark op with
| Minus _ -> Format.fprintf fmt "-"
| Not -> Format.fprintf fmt "not"
| Log (entry, infos) -> assert false (* should not happen *)
| Length -> Format.fprintf fmt "%s" "list_length"
| IntToRat -> Format.fprintf fmt "%s" "decimal_of_integer"
| MoneyToRat -> Format.fprintf fmt "%s" "decimal_of_money"
| RatToMoney -> Format.fprintf fmt "%s" "money_of_decimal"
| GetDay -> Format.fprintf fmt "%s" "day_of_month_of_date"
| GetMonth -> Format.fprintf fmt "%s" "month_number_of_date"
| GetYear -> Format.fprintf fmt "%s" "year_of_date"
| FirstDayOfMonth -> Format.fprintf fmt "%s" "first_day_of_month"
| LastDayOfMonth -> Format.fprintf fmt "%s" "last_day_of_month"
| RoundMoney -> Format.fprintf fmt "%s" "money_round"
| RoundDecimal -> Format.fprintf fmt "%s" "decimal_round"
@ -123,7 +131,7 @@ let format_struct_name (fmt : Format.formatter) (v : Dcalc.Ast.StructName.t) :
unit =
Format.fprintf fmt "%s"
(avoid_keywords
(to_uppercase
(to_camel_case
(to_ascii (Format.asprintf "%a" Dcalc.Ast.StructName.format_t v))))
let format_struct_field_name
@ -137,7 +145,7 @@ let format_enum_name (fmt : Format.formatter) (v : Dcalc.Ast.EnumName.t) : unit
=
Format.fprintf fmt "%s"
(avoid_keywords
(to_uppercase
(to_camel_case
(to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumName.format_t v))))
let format_enum_cons_name
@ -147,19 +155,19 @@ let format_enum_cons_name
(avoid_keywords
(to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumConstructor.format_t v)))
let typ_needs_parens (e : Dcalc.Ast.typ Pos.marked) : bool =
match Pos.unmark e with TArrow _ | TArray _ -> true | _ -> false
let typ_needs_parens (e : Dcalc.Ast.typ Marked.pos) : bool =
match Marked.unmark e with TArrow _ | TArray _ -> true | _ -> false
let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Pos.marked) :
let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Marked.pos) :
unit =
let format_typ = format_typ in
let format_typ_with_parens
(fmt : Format.formatter)
(t : Dcalc.Ast.typ Pos.marked) =
(t : Dcalc.Ast.typ Marked.pos) =
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
match Marked.unmark typ with
| TLit TUnit -> Format.fprintf fmt "Unit"
| TLit TMoney -> Format.fprintf fmt "Money"
| TLit TInt -> Format.fprintf fmt "Integer"
@ -185,14 +193,13 @@ let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Pos.marked) :
| TAny -> Format.fprintf fmt "Any"
let format_name_cleaned (fmt : Format.formatter) (s : string) : unit =
let lowercase_name = to_lowercase (to_ascii s) in
let lowercase_name =
Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.")
~subst:(fun _ -> "_dot_")
lowercase_name
in
let lowercase_name = avoid_keywords (to_ascii lowercase_name) in
Format.fprintf fmt "%s" lowercase_name
s
|> to_ascii
|> to_snake_case
|> Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.") ~subst:(fun _ -> "_dot_")
|> to_ascii
|> avoid_keywords
|> Format.fprintf fmt "%s"
module StringMap = Map.Make (String)
module IntMap = Map.Make (Int)
@ -205,7 +212,7 @@ module IntMap = Map.Make (Int)
let string_counter_map : int IntMap.t StringMap.t ref = ref StringMap.empty
let format_var (fmt : Format.formatter) (v : LocalName.t) : unit =
let v_str = Pos.unmark (LocalName.get_info v) in
let v_str = Marked.unmark (LocalName.get_info v) in
let hash = LocalName.hash v in
let local_id =
match StringMap.find_opt v_str !string_counter_map with
@ -236,22 +243,29 @@ let format_var (fmt : Format.formatter) (v : LocalName.t) : unit =
else Format.fprintf fmt "%a_%d" format_name_cleaned v_str local_id
let format_toplevel_name (fmt : Format.formatter) (v : TopLevelName.t) : unit =
let v_str = Pos.unmark (TopLevelName.get_info v) in
let v_str = Marked.unmark (TopLevelName.get_info v) in
format_name_cleaned fmt v_str
let needs_parens (e : expr Pos.marked) : bool =
match Pos.unmark e with
let needs_parens (e : expr Marked.pos) : bool =
match Marked.unmark e with
| ELit (LBool _ | LUnit) | EVar _ | EOp _ -> false
| _ -> true
let format_exception (fmt : Format.formatter) (exc : L.except Pos.marked) : unit
let format_exception (fmt : Format.formatter) (exc : L.except Marked.pos) : unit
=
match Pos.unmark exc with
| ConflictError -> Format.fprintf fmt "ConflictError"
let pos = Marked.get_mark exc in
match Marked.unmark exc with
| ConflictError ->
Format.fprintf fmt
"ConflictError(@[<hov 0>SourcePosition(@[<hov 0>filename=\"%s\",@ \
start_line=%d,@ start_column=%d,@ end_line=%d,@ end_column=%d,@ \
law_headings=%a)@])@]"
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
(Pos.get_law_info pos)
| EmptyError -> Format.fprintf fmt "EmptyError"
| Crash -> Format.fprintf fmt "Crash"
| NoValueProvided ->
let pos = Pos.get_position exc in
Format.fprintf fmt
"NoValueProvided(@[<hov 0>SourcePosition(@[<hov 0>filename=\"%s\",@ \
start_line=%d,@ start_column=%d,@ end_line=%d,@ end_column=%d,@ \
@ -263,8 +277,8 @@ let format_exception (fmt : Format.formatter) (exc : L.except Pos.marked) : unit
let rec format_expression
(ctx : Dcalc.Ast.decl_ctx)
(fmt : Format.formatter)
(e : expr Pos.marked) : unit =
match Pos.unmark e with
(e : expr Marked.pos) : unit =
match Marked.unmark e with
| EVar v -> format_var fmt v
| EFunc f -> format_toplevel_name fmt f
| EStruct (es, s) ->
@ -299,7 +313,7 @@ let rec format_expression
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt e -> Format.fprintf fmt "%a" (format_expression ctx) e))
es
| ELit l -> Format.fprintf fmt "%a" format_lit (Pos.same_pos_as l e)
| ELit l -> Format.fprintf fmt "%a" format_lit (Marked.same_mark_as l e)
| EApp
((EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), [arg1; arg2])
->
@ -336,6 +350,19 @@ let rec format_expression
| EApp ((EOp (Unop op), _), [arg1]) ->
Format.fprintf fmt "%a(%a)" format_unop (op, Pos.no_pos)
(format_expression ctx) arg1
| EApp ((EFunc x, pos), args)
when Ast.TopLevelName.compare x Ast.handle_default = 0
|| Ast.TopLevelName.compare x Ast.handle_default_opt = 0 ->
Format.fprintf fmt
"%a(@[<hov 0>SourcePosition(filename=\"%s\",@ start_line=%d,@ \
start_column=%d,@ end_line=%d, end_column=%d,@ law_headings=%a), %a)@]"
format_toplevel_name x (Pos.get_file pos) (Pos.get_start_line pos)
(Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos)
format_string_list (Pos.get_law_info pos)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(format_expression ctx))
args
| EApp (f, args) ->
Format.fprintf fmt "%a(@[<hov 0>%a)@]" (format_expression ctx) f
(Format.pp_print_list
@ -349,20 +376,21 @@ let rec format_expression
let rec format_statement
(ctx : Dcalc.Ast.decl_ctx)
(fmt : Format.formatter)
(s : stmt Pos.marked) : unit =
match Pos.unmark s with
(s : stmt Marked.pos) : unit =
match Marked.unmark s with
| SInnerFuncDef (name, { func_params; func_body }) ->
Format.fprintf fmt "@[<hov 4>def %a(%a):@\n%a@]" format_var
(Pos.unmark name)
(Marked.unmark name)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun fmt (var, typ) ->
Format.fprintf fmt "%a:%a" format_var (Pos.unmark var) format_typ typ))
Format.fprintf fmt "%a:%a" format_var (Marked.unmark var) format_typ
typ))
func_params (format_block ctx) func_body
| SLocalDecl _ ->
assert false (* We don't need to declare variables in Python *)
| SLocalDef (v, e) ->
Format.fprintf fmt "@[<hov 4>%a = %a@]" format_var (Pos.unmark v)
Format.fprintf fmt "@[<hov 4>%a = %a@]" format_var (Marked.unmark v)
(format_expression ctx) e
| STryExcept (try_b, except, catch_b) ->
Format.fprintf fmt "@[<hov 4>try:@\n%a@]@\n@[<hov 4>except %a:@\n%a@]"
@ -370,7 +398,7 @@ let rec format_statement
(format_block ctx) catch_b
| SRaise except ->
Format.fprintf fmt "@[<hov 4>raise %a@]" format_exception
(except, Pos.get_position s)
(except, Marked.get_mark s)
| SIfThenElse (cond, b1, b2) ->
Format.fprintf fmt "@[<hov 4>if %a:@\n%a@]@\n@[<hov 4>else:@\n%a@]"
(format_expression ctx) cond (format_block ctx) b1 (format_block ctx) b2
@ -408,10 +436,19 @@ let rec format_statement
cases
| SReturn e1 ->
Format.fprintf fmt "@[<hov 4>return %a@]" (format_expression ctx)
(e1, Pos.get_position s)
(e1, Marked.get_mark s)
| SAssert e1 ->
Format.fprintf fmt "@[<hov 4>assert %a@]" (format_expression ctx)
(e1, Pos.get_position s)
let pos = Marked.get_mark s in
Format.fprintf fmt
"@[<hov 4>if not (%a):@\n\
raise AssertionFailure(@[<hov 0>SourcePosition(@[<hov \
0>filename=\"%s\",@ start_line=%d,@ start_column=%d,@ end_line=%d,@ \
end_column=%d,@ law_headings=@[<hv>%a@])@])@]@]"
(format_expression ctx)
(e1, Marked.get_mark s)
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
(Pos.get_law_info pos)
and format_block (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (b : block)
: unit =
@ -419,7 +456,7 @@ and format_block (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (b : block)
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(format_statement ctx) fmt
(List.filter
(fun s -> match Pos.unmark s with SLocalDecl _ -> false | _ -> true)
(fun s -> match Marked.unmark s with SLocalDecl _ -> false | _ -> true)
b)
let format_ctx
@ -429,20 +466,20 @@ let format_ctx
let format_struct_decl fmt (struct_name, struct_fields) =
Format.fprintf fmt
"class %a:@\n\
\tdef __init__(self, %a) -> None:@\n\
\ def __init__(self, %a) -> None:@\n\
%a@\n\
@\n\
\tdef __eq__(self, other: object) -> bool:@\n\
\t\tif isinstance(other, %a):@\n\
\t\t\treturn @[<hov>(%a)@]@\n\
\t\telse:@\n\
\t\t\treturn False@\n\
\ def __eq__(self, other: object) -> bool:@\n\
\ if isinstance(other, %a):@\n\
\ return @[<hov>(%a)@]@\n\
\ else:@\n\
\ return False@\n\
@\n\
\tdef __ne__(self, other: object) -> bool:@\n\
\t\treturn not (self == other)@\n\
\ def __ne__(self, other: object) -> bool:@\n\
\ return not (self == other)@\n\
@\n\
\tdef __str__(self) -> str:@\n\
\t\t@[<hov 4>return \"%a(%a)\".format(%a)@]" format_struct_name
\ def __str__(self) -> str:@\n\
\ @[<hov 4>return \"%a(%a)\".format(%a)@]" format_struct_name
struct_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
@ -451,12 +488,12 @@ let format_ctx
format_typ struct_field_type))
struct_fields
(if List.length struct_fields = 0 then fun fmt _ ->
Format.fprintf fmt "\t\tpass"
Format.fprintf fmt " pass"
else
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun _fmt (struct_field, _) ->
Format.fprintf fmt "\t\tself.%a = %a" format_struct_field_name
Format.fprintf fmt " self.%a = %a" format_struct_field_name
struct_field format_struct_field_name struct_field))
struct_fields format_struct_name struct_name
(if List.length struct_fields > 0 then
@ -486,23 +523,24 @@ let format_ctx
%a@]@\n\
@\n\
class %a:@\n\
\tdef __init__(self, code: %a_Code, value: Any) -> None:@\n\
\t\tself.code = code@\n\
\t\tself.value = value@\n\
\ def __init__(self, code: %a_Code, value: Any) -> None:@\n\
\ self.code = code@\n\
\ self.value = value@\n\
@\n\
@\n\
\tdef __eq__(self, other: object) -> bool:@\n\
\t\tif isinstance(other, %a):@\n\
\t\t\treturn self.code == other.code and self.value == other.value@\n\
\t\telse:@\n\
\t\t\treturn False@\n\
\ def __eq__(self, other: object) -> bool:@\n\
\ if isinstance(other, %a):@\n\
\ return self.code == other.code and self.value == \
other.value@\n\
\ else:@\n\
\ return False@\n\
@\n\
@\n\
\tdef __ne__(self, other: object) -> bool:@\n\
\t\treturn not (self == other)@\n\
\ def __ne__(self, other: object) -> bool:@\n\
\ return not (self == other)@\n\
@\n\
\tdef __str__(self) -> str:@\n\
\t\t@[<hov 4>return \"{}({})\".format(self.code, self.value)@]"
\ def __str__(self) -> str:@\n\
\ @[<hov 4>return \"{}({})\".format(self.code, self.value)@]"
format_enum_name enum_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
@ -547,28 +585,28 @@ let format_program
(* We disable the style flag in order to enjoy formatting from the
pretty-printers of Dcalc and Lcalc but without the color terminal
markers. *)
Cli.style_flag := false;
Format.fprintf fmt
"# This file has been generated by the Catala compiler, do not edit!\n\
@\n\
from catala.runtime import *@\n\
from typing import Any, List, Callable, Tuple\n\
from enum import Enum\n\
@\n\
%a@\n\
@\n\
%a@?"
(format_ctx type_ordering) p.decl_ctx
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n@\n")
(fun fmt body ->
let { Ast.func_params; Ast.func_body } = body.scope_body_func in
Format.fprintf fmt "@[<hov 4>def %a(%a):@\n%a@]" format_toplevel_name
body.scope_body_var
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun fmt (var, typ) ->
Format.fprintf fmt "%a:%a" format_var (Pos.unmark var)
format_typ typ))
func_params (format_block p.decl_ctx) func_body))
p.scopes
Cli.call_unstyled (fun _ ->
Format.fprintf fmt
"# This file has been generated by the Catala compiler, do not edit!\n\
@\n\
from catala.runtime import *@\n\
from typing import Any, List, Callable, Tuple\n\
from enum import Enum\n\
@\n\
%a@\n\
@\n\
%a@?"
(format_ctx type_ordering) p.decl_ctx
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n@\n")
(fun fmt body ->
let { Ast.func_params; Ast.func_body } = body.scope_body_func in
Format.fprintf fmt "@[<hov 4>def %a(%a):@\n%a@]"
format_toplevel_name body.scope_body_var
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun fmt (var, typ) ->
Format.fprintf fmt "%a:%a" format_var (Marked.unmark var)
format_typ typ))
func_params (format_block p.decl_ctx) func_body))
p.scopes)

115
compiler/scopelang/ast.ml
View File

@ -51,16 +51,16 @@ module EnumConstructorMap : Map.S with type key = EnumConstructor.t =
module EnumConstructorMapLift = Bindlib.Lift (EnumConstructorMap)
type location =
| ScopeVar of ScopeVar.t Pos.marked
| ScopeVar of ScopeVar.t Marked.pos
| SubScopeVar of
ScopeName.t * SubScopeName.t Pos.marked * ScopeVar.t Pos.marked
ScopeName.t * SubScopeName.t Marked.pos * ScopeVar.t Marked.pos
module LocationSet : Set.S with type elt = location Pos.marked =
module LocationSet : Set.S with type elt = location Marked.pos =
Set.Make (struct
type t = location Pos.marked
type t = location Marked.pos
let compare x y =
match Pos.unmark x, Pos.unmark y with
match Marked.unmark x, Marked.unmark y with
| ScopeVar (vx, _), ScopeVar (vy, _) -> ScopeVar.compare vx vy
| ( SubScopeVar (_, (xsubindex, _), (xsubvar, _)),
SubScopeVar (_, (ysubindex, _), (ysubvar, _)) ) ->
@ -74,7 +74,7 @@ type typ =
| TLit of Dcalc.Ast.typ_lit
| TStruct of StructName.t
| TEnum of EnumName.t
| TArrow of typ Pos.marked * typ Pos.marked
| TArrow of typ Marked.pos * typ Marked.pos
| TArray of typ
| TAny
@ -102,23 +102,23 @@ module Typ = struct
| _, TArray _ -> 1
end
type expr =
type marked_expr = expr Marked.pos
and 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
| EVar of expr Bindlib.var
| EStruct of StructName.t * marked_expr StructFieldMap.t
| EStructAccess of marked_expr * StructFieldName.t * StructName.t
| EEnumInj of marked_expr * EnumConstructor.t * EnumName.t
| EMatch of marked_expr * EnumName.t * marked_expr EnumConstructorMap.t
| ELit of Dcalc.Ast.lit
| EAbs of
(expr, expr Pos.marked) Bindlib.mbinder Pos.marked * typ Pos.marked list
| EApp of expr Pos.marked * expr Pos.marked list
| EAbs of (expr, marked_expr) Bindlib.mbinder * typ Marked.pos list
| EApp of marked_expr * marked_expr list
| EOp of Dcalc.Ast.operator
| EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
| EArray of expr Pos.marked list
| ErrorOnEmpty of expr Pos.marked
| EDefault of marked_expr list * marked_expr * marked_expr
| EIfThenElse of marked_expr * marked_expr * marked_expr
| EArray of marked_expr list
| ErrorOnEmpty of marked_expr
module Expr = struct
type t = expr
@ -136,13 +136,11 @@ module Expr = struct
in
match e1, e2 with
| ELocation _, ELocation _ -> 0
| EVar (v1, _), EVar (v2, _) -> Bindlib.compare_vars v1 v2
| EVar v1, EVar v2 -> Bindlib.compare_vars v1 v2
| EStruct (name1, field_map1), EStruct (name2, field_map2) -> (
match StructName.compare name1 name2 with
| 0 ->
StructFieldMap.compare
(Pos.compare_marked compare)
field_map1 field_map2
StructFieldMap.compare (Marked.compare compare) field_map1 field_map2
| n -> n)
| ( EStructAccess ((e1, _), field_name1, struct_name1),
EStructAccess ((e2, _), field_name2, struct_name2) ) -> (
@ -163,13 +161,12 @@ module Expr = struct
match compare e1 e2 with
| 0 -> (
match EnumName.compare name1 name2 with
| 0 ->
EnumConstructorMap.compare (Pos.compare_marked compare) emap1 emap2
| 0 -> EnumConstructorMap.compare (Marked.compare compare) emap1 emap2
| n -> n)
| n -> n)
| ELit l1, ELit l2 -> Stdlib.compare l1 l2
| EAbs ((binder1, _), typs1), EAbs ((binder2, _), typs2) -> (
match list_compare (Pos.compare_marked Typ.compare) typs1 typs2 with
| EAbs (binder1, typs1), EAbs (binder2, typs2) -> (
match list_compare (Marked.compare Typ.compare) typs1 typs2 with
| 0 ->
let _, (e1, _), (e2, _) = Bindlib.unmbind2 binder1 binder2 in
compare e1 e2
@ -184,7 +181,7 @@ module Expr = struct
match compare just1 just2 with
| 0 -> (
match compare cons1 cons2 with
| 0 -> list_compare (Pos.compare_marked compare) exs1 exs2
| 0 -> list_compare (Marked.compare compare) exs1 exs2
| n -> n)
| n -> n)
| ( EIfThenElse ((i1, _), (t1, _), (e1, _)),
@ -225,11 +222,11 @@ end
module ExprMap = Map.Make (Expr)
let rec locations_used (e : expr Pos.marked) : LocationSet.t =
match Pos.unmark e with
| ELocation l -> LocationSet.singleton (l, Pos.get_position e)
let rec locations_used (e : expr Marked.pos) : LocationSet.t =
match Marked.unmark e with
| ELocation l -> LocationSet.singleton (l, Marked.get_mark e)
| EVar _ | ELit _ | EOp _ -> LocationSet.empty
| EAbs ((binder, _), _) ->
| EAbs (binder, _) ->
let _, body = Bindlib.unmbind binder in
locations_used body
| EStruct (_, es) ->
@ -261,21 +258,21 @@ let rec locations_used (e : expr Pos.marked) : LocationSet.t =
| ErrorOnEmpty e' -> locations_used e'
type io_input = NoInput | OnlyInput | Reentrant
type io = { io_output : bool Pos.marked; io_input : io_input Pos.marked }
type io = { io_output : bool Marked.pos; io_input : io_input Marked.pos }
type rule =
| Definition of location Pos.marked * typ Pos.marked * io * expr Pos.marked
| Assertion of expr Pos.marked
| Definition of location Marked.pos * typ Marked.pos * io * expr Marked.pos
| Assertion of expr Marked.pos
| Call of ScopeName.t * SubScopeName.t
type scope_decl = {
scope_decl_name : ScopeName.t;
scope_sig : (typ Pos.marked * io) ScopeVarMap.t;
scope_sig : (typ Marked.pos * io) 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 struct_ctx = (StructFieldName.t * typ Marked.pos) list StructMap.t
type enum_ctx = (EnumConstructor.t * typ Marked.pos) list EnumMap.t
type program = {
program_scopes : scope_decl ScopeMap.t;
@ -286,46 +283,38 @@ type program = {
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 make (s : string) : t =
Bindlib.new_var (fun (x : expr Bindlib.var) : expr -> EVar x) 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 =
let make_var ((x, pos) : Var.t Marked.pos) : expr Marked.pos 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 ((b, pos_binder), taus), pos)
(Bindlib.bind_mvar xs e)
(e : expr Marked.pos Bindlib.box)
(taus : typ Marked.pos list)
(pos : Pos.t) : expr Marked.pos Bindlib.box =
Bindlib.box_apply (fun b -> EAbs (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 =
(e : expr Marked.pos Bindlib.box)
(u : expr Marked.pos Bindlib.box list)
(pos : Pos.t) : expr Marked.pos 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 =
(tau : typ Marked.pos)
(e1 : expr Marked.pos Bindlib.box)
(e2 : expr Marked.pos Bindlib.box) : expr Marked.pos 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)))
(fun e u -> EApp (e, u), Marked.get_mark (Bindlib.unbox e2))
(make_abs (Array.of_list [x]) e2 [tau] (Marked.get_mark (Bindlib.unbox e2)))
(Bindlib.box_list [e1])
let make_default ?(pos = Pos.no_pos) exceptions just cons =
@ -344,7 +333,7 @@ let make_default ?(pos = Pos.no_pos) exceptions just cons =
EDefault (exceptions, just, cons), pos
| [except], Some false, _ -> except
| exceptions, _, cons ->
let pos = if pos <> Pos.no_pos then pos else Pos.get_position just in
let pos = if pos <> Pos.no_pos then pos else Marked.get_mark just in
EDefault (exceptions, just, cons), pos
module VarMap = Map.Make (Var)

85
compiler/scopelang/ast.mli
View File

@ -50,11 +50,11 @@ module EnumConstructorMapLift : sig
end
type location =
| ScopeVar of ScopeVar.t Pos.marked
| ScopeVar of ScopeVar.t Marked.pos
| SubScopeVar of
ScopeName.t * SubScopeName.t Pos.marked * ScopeVar.t Pos.marked
ScopeName.t * SubScopeName.t Marked.pos * ScopeVar.t Marked.pos
module LocationSet : Set.S with type elt = location Pos.marked
module LocationSet : Set.S with type elt = location Marked.pos
(** {1 Abstract syntax tree} *)
@ -62,36 +62,36 @@ type typ =
| TLit of Dcalc.Ast.typ_lit
| TStruct of StructName.t
| TEnum of EnumName.t
| TArrow of typ Pos.marked * typ Pos.marked
| TArrow of typ Marked.pos * typ Marked.pos
| TArray of typ
| TAny
module Typ : Set.OrderedType with type t = typ
type marked_expr = expr Marked.pos
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib}
library, based on higher-order abstract syntax*)
type expr =
and 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
| EVar of expr Bindlib.var
| EStruct of StructName.t * marked_expr StructFieldMap.t
| EStructAccess of marked_expr * StructFieldName.t * StructName.t
| EEnumInj of marked_expr * EnumConstructor.t * EnumName.t
| EMatch of marked_expr * EnumName.t * marked_expr EnumConstructorMap.t
| ELit of Dcalc.Ast.lit
| EAbs of
(expr, expr Pos.marked) Bindlib.mbinder Pos.marked * typ Pos.marked list
| EApp of expr Pos.marked * expr Pos.marked list
| EAbs of (expr, marked_expr) Bindlib.mbinder * typ Marked.pos list
| EApp of marked_expr * marked_expr list
| EOp of Dcalc.Ast.operator
| EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
| EArray of expr Pos.marked list
| ErrorOnEmpty of expr Pos.marked
| EDefault of marked_expr list * marked_expr * marked_expr
| EIfThenElse of marked_expr * marked_expr * marked_expr
| EArray of marked_expr list
| ErrorOnEmpty of marked_expr
module Expr : Set.OrderedType with type t = expr
module ExprMap : Map.S with type key = expr
val locations_used : expr Pos.marked -> LocationSet.t
val locations_used : expr Marked.pos -> LocationSet.t
(** This type characterizes the three levels of visibility for a given scope
variable with regards to the scope's input and possible redefinitions inside
@ -108,25 +108,25 @@ type io_input =
caller as they appear in the input. *)
type io = {
io_output : bool Pos.marked;
io_output : bool Marked.pos;
(** [true] is present in the output of the scope. *)
io_input : io_input Pos.marked;
io_input : io_input Marked.pos;
}
(** Characterization of the input/output status of a scope variable. *)
type rule =
| Definition of location Pos.marked * typ Pos.marked * io * expr Pos.marked
| Assertion of expr Pos.marked
| Definition of location Marked.pos * typ Marked.pos * io * expr Marked.pos
| Assertion of expr Marked.pos
| Call of ScopeName.t * SubScopeName.t
type scope_decl = {
scope_decl_name : ScopeName.t;
scope_sig : (typ Pos.marked * io) ScopeVarMap.t;
scope_sig : (typ Marked.pos * io) 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 struct_ctx = (StructFieldName.t * typ Marked.pos) list StructMap.t
type enum_ctx = (EnumConstructor.t * typ Marked.pos) list EnumMap.t
type program = {
program_scopes : scope_decl ScopeMap.t;
@ -139,7 +139,7 @@ type program = {
module Var : sig
type t = expr Bindlib.var
val make : string Pos.marked -> t
val make : string -> t
val compare : t -> t -> int
end
@ -147,35 +147,34 @@ module VarMap : Map.S with type key = Var.t
type vars = expr Bindlib.mvar
val make_var : Var.t Pos.marked -> expr Pos.marked Bindlib.box
val make_var : Var.t Marked.pos -> expr Marked.pos Bindlib.box
val make_abs :
vars ->
expr Pos.marked Bindlib.box ->
expr Marked.pos Bindlib.box ->
typ Marked.pos list ->
Pos.t ->
typ Pos.marked list ->
Pos.t ->
expr Pos.marked Bindlib.box
expr Marked.pos Bindlib.box
val make_app :
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box list ->
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box list ->
Pos.t ->
expr Pos.marked Bindlib.box
expr Marked.pos Bindlib.box
val make_let_in :
Var.t ->
typ Pos.marked ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box ->
expr Pos.marked Bindlib.box
typ Marked.pos ->
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box ->
expr Marked.pos Bindlib.box
val make_default :
?pos:Pos.t ->
expr Pos.marked list ->
expr Pos.marked ->
expr Pos.marked ->
expr Pos.marked
expr Marked.pos list ->
expr Marked.pos ->
expr Marked.pos ->
expr Marked.pos
(** [make_default ?pos exceptions just cons] builds a term semantically
equivalent to [<exceptions | just :- cons>] (the [EDefault] constructor)
while avoiding redundant nested constructions. The position is extracted

28
compiler/scopelang/dependency.ml
View File

@ -61,14 +61,14 @@ let build_program_dep_graph (prgm : Ast.program) : SDependencies.t =
| Ast.Call (subscope, subindex) ->
if subscope = scope_name then
Errors.raise_spanned_error
(Pos.get_position
(Marked.get_mark
(Ast.ScopeName.get_info scope.Ast.scope_decl_name))
"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
else
Ast.ScopeMap.add subscope
(Pos.get_position (Ast.SubScopeName.get_info subindex))
(Marked.get_mark (Ast.SubScopeName.get_info subindex))
acc)
Ast.ScopeMap.empty scope.Ast.scope_decl_rules
in
@ -100,10 +100,11 @@ let check_for_cycle_in_scope (g : SDependencies.t) : unit =
let succ_str = Format.asprintf "%a" Ast.ScopeName.format_t succ in
[
( Some ("Cycle variable " ^ var_str ^ ", declared:"),
Pos.get_position var_info );
Marked.get_mark var_info );
( Some
("Used here in the definition of another cycle variable "
^ succ_str ^ ":"),
^ succ_str
^ ":"),
edge_pos );
])
scc)
@ -165,8 +166,8 @@ 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
let rec get_structs_or_enums_in_type (t : Ast.typ Marked.pos) : TVertexSet.t =
match Marked.unmark t with
| Ast.TStruct s -> TVertexSet.singleton (TVertex.Struct s)
| Ast.TEnum e -> TVertexSet.singleton (TVertex.Enum e)
| Ast.TArrow (t1, t2) ->
@ -174,7 +175,7 @@ let rec get_structs_or_enums_in_type (t : Ast.typ Pos.marked) : TVertexSet.t =
(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)
| Ast.TArray t1 -> get_structs_or_enums_in_type (Marked.same_mark_as t1 t)
let build_type_graph (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) :
TDependencies.t =
@ -190,13 +191,13 @@ let build_type_graph (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) :
TVertexSet.fold
(fun used g ->
if TVertex.equal used def then
Errors.raise_spanned_error (Pos.get_position typ)
Errors.raise_spanned_error (Marked.get_mark typ)
"The type %a is defined using itself, which is forbidden \
since Catala does not provide recursive types"
TVertex.format_t used
else
let edge =
TDependencies.E.create used (Pos.get_position typ) def
TDependencies.E.create used (Marked.get_mark typ) def
in
TDependencies.add_edge_e g edge)
used g)
@ -214,13 +215,13 @@ let build_type_graph (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) :
TVertexSet.fold
(fun used g ->
if TVertex.equal used def then
Errors.raise_spanned_error (Pos.get_position typ)
Errors.raise_spanned_error (Marked.get_mark typ)
"The type %a is defined using itself, which is forbidden \
since Catala does not provide recursive types"
TVertex.format_t used
else
let edge =
TDependencies.E.create used (Pos.get_position typ) def
TDependencies.E.create used (Marked.get_mark typ) def
in
TDependencies.add_edge_e g edge)
used g)
@ -251,10 +252,11 @@ let check_type_cycles (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) :
let succ_str = Format.asprintf "%a" TVertex.format_t succ in
[
( Some ("Cycle type " ^ var_str ^ ", declared:"),
Pos.get_position var_info );
Marked.get_mark var_info );
( Some
("Used here in the definition of another cycle type "
^ succ_str ^ ":"),
^ succ_str
^ ":"),
edge_pos );
])
scc)

2
compiler/scopelang/dependency.mli
View File

@ -48,6 +48,6 @@ module TVertexSet : Set.S with type elt = TVertex.t
module TDependencies :
Graph.Sig.P with type V.t = TVertex.t and type E.label = Pos.t
val get_structs_or_enums_in_type : Ast.typ Pos.marked -> TVertexSet.t
val get_structs_or_enums_in_type : Ast.typ Marked.pos -> TVertexSet.t
val build_type_graph : Ast.struct_ctx -> Ast.enum_ctx -> TDependencies.t
val check_type_cycles : Ast.struct_ctx -> Ast.enum_ctx -> TVertex.t list

71
compiler/scopelang/print.ml
View File

@ -17,30 +17,30 @@
open Utils
open Ast
let needs_parens (e : expr Pos.marked) : bool =
match Pos.unmark e with EAbs _ -> true | _ -> false
let needs_parens (e : expr Marked.pos) : bool =
match Marked.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)
| ScopeVar v -> Format.fprintf fmt "%a" ScopeVar.format_t (Marked.unmark v)
| SubScopeVar (_, subindex, subvar) ->
Format.fprintf fmt "%a.%a" SubScopeName.format_t (Pos.unmark subindex)
ScopeVar.format_t (Pos.unmark subvar)
Format.fprintf fmt "%a.%a" SubScopeName.format_t (Marked.unmark subindex)
ScopeVar.format_t (Marked.unmark subvar)
let typ_needs_parens (e : typ Pos.marked) : bool =
match Pos.unmark e with TArrow _ -> true | _ -> false
let typ_needs_parens (e : typ Marked.pos) : bool =
match Marked.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) =
let rec format_typ (fmt : Format.formatter) (typ : typ Marked.pos) : unit =
let format_typ_with_parens (fmt : Format.formatter) (t : typ Marked.pos) =
if typ_needs_parens t then
Format.fprintf fmt "%a%a%a" Dcalc.Print.format_punctuation "(" format_typ
t Dcalc.Print.format_punctuation ")"
else Format.fprintf fmt "%a" format_typ t
in
match Pos.unmark typ with
match Marked.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
@ -48,24 +48,24 @@ let rec format_typ (fmt : Format.formatter) (typ : typ Pos.marked) : unit =
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" format_typ_with_parens t1
Dcalc.Print.format_operator "→" format_typ t2
| TArray t1 ->
Format.fprintf fmt "@[%a@ %a@]" format_typ (Pos.same_pos_as t1 typ)
Format.fprintf fmt "@[%a@ %a@]" format_typ
(Marked.same_mark_as t1 typ)
Dcalc.Print.format_base_type "array"
| TAny -> Format.fprintf fmt "any"
let rec format_expr
?(debug : bool = false)
(fmt : Format.formatter)
(e : expr Pos.marked) : unit =
(e : expr Marked.pos) : unit =
let format_expr = format_expr ~debug in
let format_with_parens (fmt : Format.formatter) (e : expr Pos.marked) =
let format_with_parens (fmt : Format.formatter) (e : expr Marked.pos) =
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
match Marked.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)
| EVar v -> Format.fprintf fmt "%a" format_var v
| ELit l -> Format.fprintf fmt "%a" Dcalc.Print.format_lit l
| EStruct (name, fields) ->
Format.fprintf fmt " @[<hov 2>%a@ %a@ %a@ %a@]" Ast.StructName.format_t name
Dcalc.Print.format_punctuation "{"
@ -97,7 +97,7 @@ let rec format_expr
Dcalc.Print.format_enum_constructor cons_name
Dcalc.Print.format_punctuation "→" format_expr case_expr))
(Ast.EnumConstructorMap.bindings cases)
| EApp ((EAbs ((binder, _), taus), _), args) ->
| EApp ((EAbs (binder, taus), _), args) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> x, tau) (Array.to_list xs) taus in
let xs_tau_arg = List.map2 (fun (x, tau) arg -> x, tau, arg) xs_tau args in
@ -111,7 +111,7 @@ let rec format_expr
Dcalc.Print.format_punctuation "=" format_expr arg
Dcalc.Print.format_keyword "in"))
xs_tau_arg format_expr body
| EAbs ((binder, _), taus) ->
| EAbs (binder, taus) ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> x, tau) (Array.to_list xs) taus in
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@]"
@ -125,11 +125,11 @@ let rec format_expr
xs_tau Dcalc.Print.format_punctuation "→" 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
Dcalc.Print.format_binop op format_with_parens arg2
| EApp ((EOp (Unop (Log _)), _), [arg1]) when not debug ->
format_expr fmt arg1
| EApp ((EOp (Unop op), _), [arg1]) ->
Format.fprintf fmt "@[%a@ %a@]" Dcalc.Print.format_unop (op, Pos.no_pos)
Format.fprintf fmt "@[%a@ %a@]" Dcalc.Print.format_unop op
format_with_parens arg1
| EApp (f, args) ->
Format.fprintf fmt "@[%a@ %a@]" format_expr f
@ -141,12 +141,9 @@ let rec format_expr
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@]"
Dcalc.Print.format_keyword "if" format_expr e1 Dcalc.Print.format_keyword
"then" format_expr e2 Dcalc.Print.format_keyword "else" format_expr e3
| EOp (Ternop op) ->
Format.fprintf fmt "%a" Dcalc.Print.format_ternop (op, Pos.no_pos)
| EOp (Binop op) ->
Format.fprintf fmt "%a" Dcalc.Print.format_binop (op, Pos.no_pos)
| EOp (Unop op) ->
Format.fprintf fmt "%a" Dcalc.Print.format_unop (op, Pos.no_pos)
| EOp (Ternop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_ternop op
| EOp (Binop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_binop op
| EOp (Unop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_unop op
| EDefault (excepts, just, cons) ->
if List.length excepts = 0 then
Format.fprintf fmt "@[%a%a %a@ %a%a@]" Dcalc.Print.format_punctuation "⟨"
@ -172,7 +169,7 @@ let rec format_expr
let format_struct
(fmt : Format.formatter)
((name, fields) : StructName.t * (StructFieldName.t * typ Pos.marked) list)
((name, fields) : StructName.t * (StructFieldName.t * typ Marked.pos) list)
: unit =
Format.fprintf fmt "%a %a %a %a@\n@[<hov 2> %a@]@\n%a"
Dcalc.Print.format_keyword "type" StructName.format_t name
@ -186,7 +183,7 @@ let format_struct
let format_enum
(fmt : Format.formatter)
((name, cases) : EnumName.t * (EnumConstructor.t * typ Pos.marked) list) :
((name, cases) : EnumName.t * (EnumConstructor.t * typ Marked.pos) list) :
unit =
Format.fprintf fmt "%a %a %a @\n@[<hov 2> %a@]" Dcalc.Print.format_keyword
"type" EnumName.format_t name Dcalc.Print.format_punctuation "="
@ -212,11 +209,11 @@ let format_scope
"(" ScopeVar.format_t scope_var Dcalc.Print.format_punctuation ":"
format_typ typ Dcalc.Print.format_punctuation "|"
Dcalc.Print.format_keyword
(match Pos.unmark vis.io_input with
(match Marked.unmark vis.io_input with
| NoInput -> "internal"
| OnlyInput -> "input"
| Reentrant -> "context")
(if Pos.unmark vis.io_output then fun fmt () ->
(if Marked.unmark vis.io_output then fun fmt () ->
Format.fprintf fmt "%a@,%a" Dcalc.Print.format_punctuation "|"
Dcalc.Print.format_keyword "output"
else fun fmt () -> Format.fprintf fmt "@<0>")
@ -230,16 +227,16 @@ let format_scope
match rule with
| Definition (loc, typ, _, e) ->
Format.fprintf fmt "@[<hov 2>%a %a %a %a %a@ %a@]"
Dcalc.Print.format_keyword "let" format_location (Pos.unmark loc)
Dcalc.Print.format_punctuation ":" format_typ typ
Dcalc.Print.format_punctuation "="
Dcalc.Print.format_keyword "let" format_location
(Marked.unmark loc) Dcalc.Print.format_punctuation ":" format_typ
typ Dcalc.Print.format_punctuation "="
(fun fmt e ->
match Pos.unmark loc with
match Marked.unmark loc with
| SubScopeVar _ -> format_expr fmt e
| ScopeVar v -> (
match
Pos.unmark
(snd (ScopeVarMap.find (Pos.unmark v) decl.scope_sig))
Marked.unmark
(snd (ScopeVarMap.find (Marked.unmark v) decl.scope_sig))
.io_input
with
| Reentrant ->

4
compiler/scopelang/print.mli
View File

@ -18,12 +18,12 @@ open Utils
val format_var : Format.formatter -> Ast.Var.t -> unit
val format_location : Format.formatter -> Ast.location -> unit
val format_typ : Format.formatter -> Ast.typ Pos.marked -> unit
val format_typ : Format.formatter -> Ast.typ Marked.pos -> unit
val format_expr :
?debug:bool (** [true] for debug printing *) ->
Format.formatter ->
Ast.expr Pos.marked ->
Ast.expr Marked.pos ->
unit
val format_scope :

693
compiler/scopelang/scope_to_dcalc.ml
View File

File diff suppressed because it is too large Load Diff

2
compiler/scopelang/scope_to_dcalc.mli
View File

@ -17,7 +17,7 @@
(** Scope language to default calculus translator *)
val translate_program :
Ast.program -> Dcalc.Ast.program * Dependency.TVertex.t list
Ast.program -> Dcalc.Ast.untyped Dcalc.Ast.program * Dependency.TVertex.t list
(** Usage [translate_program p] returns a tuple [(new_program, types_list)]
where [new_program] is the map of translated scopes. Finally, [types_list]
is a list of all types (structs and enums) used in the program, correctly

206
compiler/surface/ast.ml
View File

@ -42,18 +42,18 @@ type ident = (string[@opaque])
visitors { variety = "iter"; name = "ident_iter"; nude = true }]
(** Idents are snake_case *)
type qident = ident Pos.marked list
type qident = ident Marked.pos list
[@@deriving
visitors
{
variety = "map";
ancestors = ["Pos.marked_map"; "ident_map"];
ancestors = ["Marked.pos_map"; "ident_map"];
name = "qident_map";
},
visitors
{
variety = "iter";
ancestors = ["Pos.marked_iter"; "ident_iter"];
ancestors = ["Marked.pos_iter"; "ident_iter"];
name = "qident_iter";
}]
@ -82,18 +82,18 @@ type primitive_typ =
type base_typ_data =
| Primitive of primitive_typ
| Collection of base_typ_data Pos.marked
| Collection of base_typ_data Marked.pos
[@@deriving
visitors
{
variety = "map";
ancestors = ["Pos.marked_map"; "primitive_typ_map"];
ancestors = ["Marked.pos_map"; "primitive_typ_map"];
name = "base_typ_data_map";
},
visitors
{
variety = "iter";
ancestors = ["Pos.marked_iter"; "primitive_typ_iter"];
ancestors = ["Marked.pos_iter"; "primitive_typ_iter"];
name = "base_typ_data_iter";
}]
@ -115,8 +115,8 @@ type base_typ = Condition | Data of base_typ_data
}]
type func_typ = {
arg_typ : base_typ Pos.marked;
return_typ : base_typ Pos.marked;
arg_typ : base_typ Marked.pos;
return_typ : base_typ Marked.pos;
}
[@@deriving
visitors
@ -152,8 +152,8 @@ type typ = Base of base_typ | Func of func_typ
}]
type struct_decl_field = {
struct_decl_field_name : ident Pos.marked;
struct_decl_field_typ : typ Pos.marked;
struct_decl_field_name : ident Marked.pos;
struct_decl_field_typ : typ Marked.pos;
}
[@@deriving
visitors
@ -170,8 +170,8 @@ type struct_decl_field = {
}]
type struct_decl = {
struct_decl_name : constructor Pos.marked;
struct_decl_fields : struct_decl_field Pos.marked list;
struct_decl_name : constructor Marked.pos;
struct_decl_fields : struct_decl_field Marked.pos list;
}
[@@deriving
visitors
@ -188,8 +188,8 @@ type struct_decl = {
}]
type enum_decl_case = {
enum_decl_case_name : constructor Pos.marked;
enum_decl_case_typ : typ Pos.marked option;
enum_decl_case_name : constructor Marked.pos;
enum_decl_case_typ : typ Marked.pos option;
}
[@@deriving
visitors
@ -208,8 +208,8 @@ type enum_decl_case = {
}]
type enum_decl = {
enum_decl_name : constructor Pos.marked;
enum_decl_cases : enum_decl_case Pos.marked list;
enum_decl_name : constructor Marked.pos;
enum_decl_cases : enum_decl_case Marked.pos list;
}
[@@deriving
visitors
@ -228,19 +228,19 @@ type enum_decl = {
}]
type match_case_pattern =
(constructor Pos.marked option * constructor Pos.marked) list
* ident Pos.marked option
(constructor Marked.pos option * constructor Marked.pos) list
* ident Marked.pos option
[@@deriving
visitors
{
variety = "map";
ancestors = ["ident_map"; "constructor_map"; "Pos.marked_map"];
ancestors = ["ident_map"; "constructor_map"; "Marked.pos_map"];
name = "match_case_pattern_map";
},
visitors
{
variety = "iter";
ancestors = ["ident_iter"; "constructor_iter"; "Pos.marked_iter"];
ancestors = ["ident_iter"; "constructor_iter"; "Marked.pos_iter"];
name = "match_case_pattern_iter";
}]
@ -300,9 +300,13 @@ type unop = Not | Minus of op_kind
type builtin_expression =
| Cardinal
| IntToDec
| MoneyToDec
| DecToMoney
| GetDay
| GetMonth
| GetYear
| LastDayOfMonth
| FirstDayOfMonth
| RoundMoney
| RoundDecimal
[@@deriving
@ -310,21 +314,21 @@ type builtin_expression =
visitors { variety = "iter"; name = "builtin_expression_iter"; nude = true }]
type literal_date = {
literal_date_day : (int[@opaque]) Pos.marked;
literal_date_month : (int[@opaque]) Pos.marked;
literal_date_year : (int[@opaque]) Pos.marked;
literal_date_day : (int[@opaque]);
literal_date_month : (int[@opaque]);
literal_date_year : (int[@opaque]);
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["Pos.marked_map"];
ancestors = ["Marked.pos_map"];
name = "literal_date_map";
},
visitors
{
variety = "iter";
ancestors = ["Pos.marked_iter"];
ancestors = ["Marked.pos_iter"];
name = "literal_date_iter";
}]
@ -349,7 +353,7 @@ type money_amount = {
visitors { variety = "iter"; name = "money_amount_iter"; nude = true }]
type literal =
| LNumber of literal_number Pos.marked * literal_unit Pos.marked option
| LNumber of literal_number Marked.pos * literal_unit Marked.pos option
| LBool of bool
| LMoneyAmount of money_amount
| LDate of literal_date
@ -382,8 +386,8 @@ type literal =
type aggregate_func =
| AggregateSum of primitive_typ
| AggregateCount
| AggregateExtremum of bool * primitive_typ * expression Pos.marked
| AggregateArgExtremum of bool * primitive_typ * expression Pos.marked
| AggregateExtremum of bool * primitive_typ * expression Marked.pos
| AggregateArgExtremum of bool * primitive_typ * expression Marked.pos
and collection_op =
| Exists
@ -393,42 +397,42 @@ and collection_op =
| Filter
and explicit_match_case = {
match_case_pattern : match_case_pattern Pos.marked;
match_case_expr : expression Pos.marked;
match_case_pattern : match_case_pattern Marked.pos;
match_case_expr : expression Marked.pos;
}
and match_case =
| WildCard of expression Pos.marked
| WildCard of expression Marked.pos
| MatchCase of explicit_match_case
and match_cases = match_case Pos.marked list
and match_cases = match_case Marked.pos list
and expression =
| MatchWith of expression Pos.marked * match_cases Pos.marked
| MatchWith of expression Marked.pos * match_cases Marked.pos
| IfThenElse of
expression Pos.marked * expression Pos.marked * expression Pos.marked
| Binop of binop Pos.marked * expression Pos.marked * expression Pos.marked
| Unop of unop Pos.marked * expression Pos.marked
expression Marked.pos * expression Marked.pos * expression Marked.pos
| Binop of binop Marked.pos * expression Marked.pos * expression Marked.pos
| Unop of unop Marked.pos * expression Marked.pos
| CollectionOp of
collection_op Pos.marked
* ident Pos.marked
* expression Pos.marked
* expression Pos.marked
| MemCollection of expression Pos.marked * expression Pos.marked
| TestMatchCase of expression Pos.marked * match_case_pattern Pos.marked
| FunCall of expression Pos.marked * expression Pos.marked
collection_op Marked.pos
* ident Marked.pos
* expression Marked.pos
* expression Marked.pos
| MemCollection of expression Marked.pos * expression Marked.pos
| TestMatchCase of expression Marked.pos * match_case_pattern Marked.pos
| FunCall of expression Marked.pos * expression Marked.pos
| Builtin of builtin_expression
| Literal of literal
| EnumInject of
constructor Pos.marked option
* constructor Pos.marked
* expression Pos.marked option
constructor Marked.pos option
* constructor Marked.pos
* expression Marked.pos option
| StructLit of
constructor Pos.marked * (ident Pos.marked * expression Pos.marked) list
| ArrayLit of expression Pos.marked list
constructor Marked.pos * (ident Marked.pos * expression Marked.pos) list
| ArrayLit of expression Marked.pos list
| Ident of ident
| Dotted of
expression Pos.marked * constructor Pos.marked option * ident Pos.marked
expression Marked.pos * constructor Marked.pos option * ident Marked.pos
(** Dotted is for both struct field projection and sub-scope variables *)
[@@deriving
visitors
@ -463,30 +467,30 @@ and expression =
type exception_to =
| NotAnException
| UnlabeledException
| ExceptionToLabel of ident Pos.marked
| ExceptionToLabel of ident Marked.pos
[@@deriving
visitors
{
variety = "map";
ancestors = ["ident_map"; "Pos.marked_map"];
ancestors = ["ident_map"; "Marked.pos_map"];
name = "exception_to_map";
},
visitors
{
variety = "iter";
ancestors = ["ident_iter"; "Pos.marked_iter"];
ancestors = ["ident_iter"; "Marked.pos_iter"];
name = "exception_to_iter";
}]
type rule = {
rule_label : ident Pos.marked option;
rule_label : ident Marked.pos option;
rule_exception_to : exception_to;
rule_parameter : ident Pos.marked option;
rule_condition : expression Pos.marked option;
rule_name : qident Pos.marked;
rule_parameter : ident Marked.pos option;
rule_condition : expression Marked.pos option;
rule_name : qident Marked.pos;
rule_id : Desugared.Ast.RuleName.t; [@opaque]
rule_consequence : (bool[@opaque]) Pos.marked;
rule_state : ident Pos.marked option;
rule_consequence : (bool[@opaque]) Marked.pos;
rule_state : ident Marked.pos option;
}
[@@deriving
visitors
@ -503,14 +507,14 @@ type rule = {
}]
type definition = {
definition_label : ident Pos.marked option;
definition_label : ident Marked.pos option;
definition_exception_to : exception_to;
definition_name : qident Pos.marked;
definition_parameter : ident Pos.marked option;
definition_condition : expression Pos.marked option;
definition_name : qident Marked.pos;
definition_parameter : ident Marked.pos option;
definition_condition : expression Marked.pos option;
definition_id : Desugared.Ast.RuleName.t; [@opaque]
definition_expr : expression Pos.marked;
definition_state : ident Pos.marked option;
definition_expr : expression Marked.pos;
definition_state : ident Marked.pos option;
}
[@@deriving
visitors
@ -532,11 +536,11 @@ type variation_typ = Increasing | Decreasing
visitors { variety = "iter"; name = "variation_typ_iter" }]
type meta_assertion =
| FixedBy of qident Pos.marked * ident Pos.marked
| FixedBy of qident Marked.pos * ident Marked.pos
| VariesWith of
qident Pos.marked
* expression Pos.marked
* variation_typ Pos.marked option
qident Marked.pos
* expression Marked.pos
* variation_typ Marked.pos option
[@@deriving
visitors
{
@ -552,8 +556,8 @@ type meta_assertion =
}]
type assertion = {
assertion_condition : expression Pos.marked option;
assertion_content : expression Pos.marked;
assertion_condition : expression Marked.pos option;
assertion_content : expression Marked.pos;
}
[@@deriving
visitors
@ -592,9 +596,9 @@ type scope_use_item =
}]
type scope_use = {
scope_use_condition : expression Pos.marked option;
scope_use_name : constructor Pos.marked;
scope_use_items : scope_use_item Pos.marked list;
scope_use_condition : expression Marked.pos option;
scope_use_name : constructor Marked.pos;
scope_use_items : scope_use_item Marked.pos list;
}
[@@deriving
visitors
@ -616,26 +620,26 @@ type io_input = Input | Context | Internal
visitors { variety = "iter"; name = "io_input_iter" }]
type scope_decl_context_io = {
scope_decl_context_io_input : io_input Pos.marked;
scope_decl_context_io_output : bool Pos.marked;
scope_decl_context_io_input : io_input Marked.pos;
scope_decl_context_io_output : bool Marked.pos;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["io_input_map"; "Pos.marked_map"];
ancestors = ["io_input_map"; "Marked.pos_map"];
name = "scope_decl_context_io_map";
},
visitors
{
variety = "iter";
ancestors = ["io_input_iter"; "Pos.marked_iter"];
ancestors = ["io_input_iter"; "Marked.pos_iter"];
name = "scope_decl_context_io_iter";
}]
type scope_decl_context_scope = {
scope_decl_context_scope_name : ident Pos.marked;
scope_decl_context_scope_sub_scope : constructor Pos.marked;
scope_decl_context_scope_name : ident Marked.pos;
scope_decl_context_scope_sub_scope : constructor Marked.pos;
scope_decl_context_scope_attribute : scope_decl_context_io;
}
[@@deriving
@ -647,7 +651,7 @@ type scope_decl_context_scope = {
"ident_map";
"constructor_map";
"scope_decl_context_io_map";
"Pos.marked_map";
"Marked.pos_map";
];
name = "scope_decl_context_scope_map";
},
@ -659,16 +663,16 @@ type scope_decl_context_scope = {
"ident_iter";
"constructor_iter";
"scope_decl_context_io_iter";
"Pos.marked_iter";
"Marked.pos_iter";
];
name = "scope_decl_context_scope_iter";
}]
type scope_decl_context_data = {
scope_decl_context_item_name : ident Pos.marked;
scope_decl_context_item_typ : typ Pos.marked;
scope_decl_context_item_name : ident Marked.pos;
scope_decl_context_item_typ : typ Marked.pos;
scope_decl_context_item_attribute : scope_decl_context_io;
scope_decl_context_item_states : ident Pos.marked list;
scope_decl_context_item_states : ident Marked.pos list;
}
[@@deriving
visitors
@ -704,8 +708,8 @@ type scope_decl_context_item =
}]
type scope_decl = {
scope_decl_name : constructor Pos.marked;
scope_decl_context : scope_decl_context_item Pos.marked list;
scope_decl_name : constructor Marked.pos;
scope_decl_context : scope_decl_context_item Marked.pos list;
}
[@@deriving
visitors
@ -747,7 +751,7 @@ type code_item =
name = "code_item_iter";
}]
type code_block = code_item Pos.marked list
type code_block = code_item Marked.pos list
[@@deriving
visitors
{ variety = "map"; ancestors = ["code_item_map"]; name = "code_block_map" },
@ -758,23 +762,23 @@ type code_block = code_item Pos.marked list
name = "code_block_iter";
}]
type source_repr = (string[@opaque]) Pos.marked
type source_repr = (string[@opaque]) Marked.pos
[@@deriving
visitors
{
variety = "map";
ancestors = ["Pos.marked_map"];
ancestors = ["Marked.pos_map"];
name = "source_repr_map";
},
visitors
{
variety = "iter";
ancestors = ["Pos.marked_iter"];
ancestors = ["Marked.pos_iter"];
name = "source_repr_iter";
}]
type law_heading = {
law_heading_name : (string[@opaque]) Pos.marked;
law_heading_name : (string[@opaque]) Marked.pos;
law_heading_id : (string[@opaque]) option;
law_heading_expiration_date : (string[@opaque]) option;
law_heading_precedence : (int[@opaque]);
@ -783,31 +787,31 @@ type law_heading = {
visitors
{
variety = "map";
ancestors = ["Pos.marked_map"];
ancestors = ["Marked.pos_map"];
name = "law_heading_map";
},
visitors
{
variety = "iter";
ancestors = ["Pos.marked_iter"];
ancestors = ["Marked.pos_iter"];
name = "law_heading_iter";
}]
type law_include =
| PdfFile of (string[@opaque]) Pos.marked * (int[@opaque]) option
| CatalaFile of (string[@opaque]) Pos.marked
| LegislativeText of (string[@opaque]) Pos.marked
| PdfFile of (string[@opaque]) Marked.pos * (int[@opaque]) option
| CatalaFile of (string[@opaque]) Marked.pos
| LegislativeText of (string[@opaque]) Marked.pos
[@@deriving
visitors
{
variety = "map";
ancestors = ["Pos.marked_map"];
ancestors = ["Marked.pos_map"];
name = "law_include_map";
},
visitors
{
variety = "iter";
ancestors = ["Pos.marked_iter"];
ancestors = ["Marked.pos_iter"];
name = "law_include_iter";
}]
@ -862,7 +866,9 @@ type source_file = law_structure list
(** Translates a {!type: rule} into the corresponding {!type: definition} *)
let rule_to_def (rule : rule) : definition =
let consequence_expr = Literal (LBool (Pos.unmark rule.rule_consequence)) in
let consequence_expr =
Literal (LBool (Marked.unmark rule.rule_consequence))
in
{
definition_label = rule.rule_label;
definition_exception_to = rule.rule_exception_to;
@ -870,6 +876,6 @@ let rule_to_def (rule : rule) : definition =
definition_parameter = rule.rule_parameter;
definition_condition = rule.rule_condition;
definition_id = rule.rule_id;
definition_expr = consequence_expr, Pos.get_position rule.rule_consequence;
definition_expr = consequence_expr, Marked.get_mark rule.rule_consequence;
definition_state = rule.rule_state;
}

392
compiler/surface/desugaring.ml
View File

@ -16,6 +16,8 @@
the License. *)
open Utils
module Runtime = Runtime_ocaml.Runtime
(** Translation from {!module: Surface.Ast} to {!module: Desugaring.Ast}.
- Removes syntactic sugars
@ -62,7 +64,7 @@ module LiftEnumConstructorMap = Bindlib.Lift (Scopelang.Ast.EnumConstructorMap)
let disambiguate_constructor
(ctxt : Name_resolution.context)
(constructor : (string Pos.marked option * string Pos.marked) list)
(constructor : (string Marked.pos option * string Marked.pos) list)
(pos : Pos.t) : Scopelang.Ast.EnumName.t * Scopelang.Ast.EnumConstructor.t =
let enum, constructor =
match constructor with
@ -73,11 +75,12 @@ let disambiguate_constructor
in
let possible_c_uids =
try
Desugared.Ast.IdentMap.find (Pos.unmark constructor)
Desugared.Ast.IdentMap.find
(Marked.unmark constructor)
ctxt.constructor_idmap
with Not_found ->
Errors.raise_spanned_error
(Pos.get_position constructor)
(Marked.get_mark constructor)
"The name of this constructor has not been defined before, maybe it is \
a typo?"
in
@ -85,7 +88,7 @@ let disambiguate_constructor
| None ->
if Scopelang.Ast.EnumMap.cardinal possible_c_uids > 1 then
Errors.raise_spanned_error
(Pos.get_position constructor)
(Marked.get_mark constructor)
"This constructor name is ambiguous, it can belong to %a. Disambiguate \
it by prefixing it with the enum name."
(Format.pp_print_list
@ -98,17 +101,18 @@ let disambiguate_constructor
try
(* The path is fully qualified *)
let e_uid =
Desugared.Ast.IdentMap.find (Pos.unmark enum) ctxt.enum_idmap
Desugared.Ast.IdentMap.find (Marked.unmark enum) ctxt.enum_idmap
in
try
let c_uid = Scopelang.Ast.EnumMap.find e_uid possible_c_uids in
e_uid, c_uid
with Not_found ->
Errors.raise_spanned_error pos "Enum %s does not contain case %s"
(Pos.unmark enum) (Pos.unmark constructor)
(Marked.unmark enum)
(Marked.unmark constructor)
with Not_found ->
Errors.raise_spanned_error (Pos.get_position enum)
"Enum %s has not been defined before" (Pos.unmark enum))
Errors.raise_spanned_error (Marked.get_mark enum)
"Enum %s has not been defined before" (Marked.unmark enum))
(** Usage: [translate_expr scope ctxt expr]
@ -116,10 +120,10 @@ let disambiguate_constructor
disambiguate the scope and subscopes variables than occur in the expresion *)
let rec translate_expr
(scope : Scopelang.Ast.ScopeName.t)
(inside_definition_of : Desugared.Ast.ScopeDef.t Pos.marked option)
(inside_definition_of : Desugared.Ast.ScopeDef.t Marked.pos option)
(ctxt : Name_resolution.context)
((expr, pos) : Ast.expression Pos.marked) :
Desugared.Ast.expr Pos.marked Bindlib.box =
((expr, pos) : Ast.expression Marked.pos) :
Desugared.Ast.expr Marked.pos Bindlib.box =
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope ctxt.scopes in
let rec_helper = translate_expr scope inside_definition_of ctxt in
match expr with
@ -137,18 +141,18 @@ let rec translate_expr
Scopelang.Ast.EnumConstructorMap.mapi
(fun c_uid' tau ->
if Scopelang.Ast.EnumConstructor.compare c_uid c_uid' <> 0 then
let nop_var = Desugared.Ast.Var.make ("_", pos) in
let nop_var = Desugared.Ast.Var.make "_" in
Bindlib.unbox
(Desugared.Ast.make_abs [| nop_var |]
(Bindlib.box (Desugared.Ast.ELit (Dcalc.Ast.LBool false), pos))
pos [tau] pos)
[tau] pos)
else
let ctxt, binding_var =
Name_resolution.add_def_local_var ctxt binding
Name_resolution.add_def_local_var ctxt (Marked.unmark binding)
in
let e2 = translate_expr scope inside_definition_of ctxt e2 in
Bindlib.unbox
(Desugared.Ast.make_abs [| binding_var |] e2 pos [tau] pos))
(Desugared.Ast.make_abs [| binding_var |] e2 [tau] pos))
(Scopelang.Ast.EnumMap.find enum_uid ctxt.enums)
in
Bindlib.box_apply
@ -161,8 +165,9 @@ let rec translate_expr
(rec_helper e_if) (rec_helper e_then) (rec_helper e_else)
| Binop (op, e1, e2) ->
let op_term =
Pos.same_pos_as
(Desugared.Ast.EOp (Dcalc.Ast.Binop (translate_binop (Pos.unmark op))))
Marked.same_mark_as
(Desugared.Ast.EOp
(Dcalc.Ast.Binop (translate_binop (Marked.unmark op))))
op
in
Bindlib.box_apply2
@ -170,8 +175,8 @@ let rec translate_expr
(rec_helper e1) (rec_helper e2)
| Unop (op, e) ->
let op_term =
Pos.same_pos_as
(Desugared.Ast.EOp (Dcalc.Ast.Unop (translate_unop (Pos.unmark op))))
Marked.same_mark_as
(Desugared.Ast.EOp (Dcalc.Ast.Unop (translate_unop (Marked.unmark op))))
op
in
Bindlib.box_apply
@ -218,21 +223,17 @@ let rec translate_expr
Errors.raise_spanned_error pos
"Impossible to specify decimal amounts of days, months or years"
| LDate date ->
if Pos.unmark date.literal_date_month > 12 then
Errors.raise_spanned_error
(Pos.get_position date.literal_date_month)
if date.literal_date_month > 12 then
Errors.raise_spanned_error pos
"There is an error in this date: the month number is bigger than 12";
if Pos.unmark date.literal_date_day > 31 then
Errors.raise_spanned_error
(Pos.get_position date.literal_date_day)
if date.literal_date_day > 31 then
Errors.raise_spanned_error pos
"There is an error in this date: the day number is bigger than 31";
Desugared.Ast.ELit
(Dcalc.Ast.LDate
(try
Runtime.date_of_numbers
(Pos.unmark date.literal_date_year)
(Pos.unmark date.literal_date_month)
(Pos.unmark date.literal_date_day)
Runtime.date_of_numbers date.literal_date_year
date.literal_date_month date.literal_date_day
with Runtime.ImpossibleDate ->
Errors.raise_spanned_error pos
"There is an error in this date, it does not correspond to a \
@ -300,11 +301,11 @@ let rec translate_expr
Desugared.Ast.make_var (uid, pos)
(* the whole box thing is to accomodate for this case *))
| Dotted (e, c, x) -> (
match Pos.unmark e with
match Marked.unmark e with
| 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)
Name_resolution.get_subscope_uid scope ctxt (Marked.same_mark_as y e)
in
let subscope_real_uid : Scopelang.Ast.ScopeName.t =
Scopelang.Ast.SubScopeMap.find subscope_uid scope_ctxt.sub_scopes
@ -321,16 +322,16 @@ let rec translate_expr
(* In this case e.x is the struct field x access of expression e *)
let e = translate_expr scope inside_definition_of ctxt e in
let x_possible_structs =
try Desugared.Ast.IdentMap.find (Pos.unmark x) ctxt.field_idmap
try Desugared.Ast.IdentMap.find (Marked.unmark x) ctxt.field_idmap
with Not_found ->
Errors.raise_spanned_error (Pos.get_position x)
Errors.raise_spanned_error (Marked.get_mark x)
"Unknown subscope or struct field name"
in
match c with
| None ->
(* No constructor name was specified *)
if Scopelang.Ast.StructMap.cardinal x_possible_structs > 1 then
Errors.raise_spanned_error (Pos.get_position x)
Errors.raise_spanned_error (Marked.get_mark x)
"This struct field name is ambiguous, it can belong to %a. \
Disambiguate it by prefixing it with the struct name."
(Format.pp_print_list
@ -349,7 +350,7 @@ let rec translate_expr
| Some c_name -> (
try
let c_uid =
Desugared.Ast.IdentMap.find (Pos.unmark c_name) ctxt.struct_idmap
Desugared.Ast.IdentMap.find (Marked.unmark c_name) ctxt.struct_idmap
in
try
let f_uid = Scopelang.Ast.StructMap.find c_uid x_possible_structs in
@ -358,19 +359,19 @@ let rec translate_expr
e
with Not_found ->
Errors.raise_spanned_error pos "Struct %s does not contain field %s"
(Pos.unmark c_name) (Pos.unmark x)
(Marked.unmark c_name) (Marked.unmark x)
with Not_found ->
Errors.raise_spanned_error (Pos.get_position c_name)
"Struct %s has not been defined before" (Pos.unmark c_name))))
Errors.raise_spanned_error (Marked.get_mark c_name)
"Struct %s has not been defined before" (Marked.unmark c_name))))
| FunCall (f, arg) ->
Bindlib.box_apply2
(fun f arg -> Desugared.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
try Desugared.Ast.IdentMap.find (Marked.unmark s_name) ctxt.struct_idmap
with Not_found ->
Errors.raise_spanned_error (Pos.get_position s_name)
Errors.raise_spanned_error (Marked.get_mark s_name)
"This identifier should refer to a struct name"
in
@ -380,20 +381,20 @@ let rec translate_expr
let f_uid =
try
Scopelang.Ast.StructMap.find s_uid
(Desugared.Ast.IdentMap.find (Pos.unmark f_name)
(Desugared.Ast.IdentMap.find (Marked.unmark f_name)
ctxt.field_idmap)
with Not_found ->
Errors.raise_spanned_error (Pos.get_position f_name)
Errors.raise_spanned_error (Marked.get_mark f_name)
"This identifier should refer to a field of struct %s"
(Pos.unmark s_name)
(Marked.unmark s_name)
in
(match Scopelang.Ast.StructFieldMap.find_opt f_uid s_fields with
| None -> ()
| Some e_field ->
Errors.raise_multispanned_error
[
None, Pos.get_position f_e;
None, Pos.get_position (Bindlib.unbox e_field);
None, Marked.get_mark f_e;
None, Marked.get_mark (Bindlib.unbox e_field);
]
"The field %a has been defined twice:"
Scopelang.Ast.StructFieldName.format_t f_uid);
@ -417,11 +418,12 @@ let rec translate_expr
| EnumInject (enum, constructor, payload) -> (
let possible_c_uids =
try
Desugared.Ast.IdentMap.find (Pos.unmark constructor)
Desugared.Ast.IdentMap.find
(Marked.unmark constructor)
ctxt.constructor_idmap
with Not_found ->
Errors.raise_spanned_error
(Pos.get_position constructor)
(Marked.get_mark constructor)
"The name of this constructor has not been defined before, maybe it \
is a typo?"
in
@ -433,7 +435,7 @@ let rec translate_expr
Scopelang.Ast.EnumMap.cardinal possible_c_uids > 1
then
Errors.raise_spanned_error
(Pos.get_position constructor)
(Marked.get_mark constructor)
"This constructor name is ambiguous, it can belong to %a. \
Desambiguate it by prefixing it with the enum name."
(Format.pp_print_list
@ -453,7 +455,7 @@ let rec translate_expr
| Some e' -> e'
| None ->
( Desugared.Ast.ELit Dcalc.Ast.LUnit,
Pos.get_position constructor )),
Marked.get_mark constructor )),
c_uid,
e_uid ),
pos ))
@ -462,7 +464,7 @@ let rec translate_expr
try
(* The path has been fully qualified *)
let e_uid =
Desugared.Ast.IdentMap.find (Pos.unmark enum) ctxt.enum_idmap
Desugared.Ast.IdentMap.find (Marked.unmark enum) ctxt.enum_idmap
in
try
let c_uid = Scopelang.Ast.EnumMap.find e_uid possible_c_uids in
@ -476,17 +478,18 @@ let rec translate_expr
| Some e' -> e'
| None ->
( Desugared.Ast.ELit Dcalc.Ast.LUnit,
Pos.get_position constructor )),
Marked.get_mark constructor )),
c_uid,
e_uid ),
pos ))
(Bindlib.box_opt payload)
with Not_found ->
Errors.raise_spanned_error pos "Enum %s does not contain case %s"
(Pos.unmark enum) (Pos.unmark constructor)
(Marked.unmark enum)
(Marked.unmark constructor)
with Not_found ->
Errors.raise_spanned_error (Pos.get_position enum)
"Enum %s has not been defined before" (Pos.unmark enum)))
Errors.raise_spanned_error (Marked.get_mark enum)
"Enum %s has not been defined before" (Marked.unmark enum)))
| MatchWith (e1, (cases, _cases_pos)) ->
let e1 = translate_expr scope inside_definition_of ctxt e1 in
let cases_d, e_uid =
@ -498,20 +501,20 @@ let rec translate_expr
e1
(LiftEnumConstructorMap.lift_box cases_d)
| TestMatchCase (e1, pattern) ->
(match snd (Pos.unmark pattern) with
(match snd (Marked.unmark pattern) with
| None -> ()
| Some binding ->
Errors.format_spanned_warning (Pos.get_position binding)
Errors.format_spanned_warning (Marked.get_mark binding)
"This binding will be ignored (remove it to suppress warning)");
let enum_uid, c_uid =
disambiguate_constructor ctxt
(fst (Pos.unmark pattern))
(Pos.get_position pattern)
(fst (Marked.unmark pattern))
(Marked.get_mark pattern)
in
let cases =
Scopelang.Ast.EnumConstructorMap.mapi
(fun c_uid' tau ->
let nop_var = Desugared.Ast.Var.make ("_", pos) in
let nop_var = Desugared.Ast.Var.make "_" in
Bindlib.unbox
(Desugared.Ast.make_abs [| nop_var |]
(Bindlib.box
@ -519,7 +522,7 @@ let rec translate_expr
(Dcalc.Ast.LBool
(Scopelang.Ast.EnumConstructor.compare c_uid c_uid' = 0)),
pos ))
pos [tau] pos))
[tau] pos))
(Scopelang.Ast.EnumMap.find enum_uid ctxt.enums)
in
Bindlib.box_apply
@ -535,11 +538,12 @@ let rec translate_expr
collection,
predicate ) ->
let collection = rec_helper collection in
let ctxt, param = Name_resolution.add_def_local_var ctxt param' in
let ctxt, param =
Name_resolution.add_def_local_var ctxt (Marked.unmark param')
in
let f_pred =
Desugared.Ast.make_abs [| param |]
(translate_expr scope inside_definition_of ctxt predicate)
pos
[Scopelang.Ast.TAny, pos]
pos
in
@ -563,7 +567,9 @@ let rec translate_expr
predicate ) ->
let init = rec_helper init in
let collection = rec_helper collection in
let ctxt, param = Name_resolution.add_def_local_var ctxt param' in
let ctxt, param =
Name_resolution.add_def_local_var ctxt (Marked.unmark param')
in
let op_kind =
match pred_typ with
| Ast.Integer -> Dcalc.Ast.KInt
@ -583,25 +589,19 @@ let rec translate_expr
let f_pred =
Desugared.Ast.make_abs [| param |]
(translate_expr scope inside_definition_of ctxt predicate)
pos
[Scopelang.Ast.TAny, pos]
pos
in
let f_pred_var =
Desugared.Ast.Var.make ("predicate", Pos.get_position predicate)
in
let f_pred_var = Desugared.Ast.Var.make "predicate" in
let f_pred_var_e =
Desugared.Ast.make_var (f_pred_var, Pos.get_position predicate)
Desugared.Ast.make_var (f_pred_var, Marked.get_mark predicate)
in
let acc_var = Desugared.Ast.Var.make ("acc", pos) in
let acc_var = Desugared.Ast.Var.make "acc" in
let acc_var_e = Desugared.Ast.make_var (acc_var, pos) in
let item_var =
Desugared.Ast.Var.make
("item", Pos.get_position (Bindlib.unbox collection))
in
let item_var = Desugared.Ast.Var.make "item" in
let item_var_e =
Desugared.Ast.make_var
(item_var, Pos.get_position (Bindlib.unbox collection))
(item_var, Marked.get_mark (Bindlib.unbox collection))
in
let fold_body =
Bindlib.box_apply3
@ -620,7 +620,7 @@ let rec translate_expr
acc_var_e item_var_e f_pred_var_e
in
let fold_f =
Desugared.Ast.make_abs [| acc_var; item_var |] fold_body pos
Desugared.Ast.make_abs [| acc_var; item_var |] fold_body
[Scopelang.Ast.TAny, pos; Scopelang.Ast.TAny, pos]
pos
in
@ -635,37 +635,39 @@ let rec translate_expr
in
Desugared.Ast.make_let_in f_pred_var (Scopelang.Ast.TAny, pos) f_pred fold
| CollectionOp (op', param', collection, predicate) ->
let ctxt, param = Name_resolution.add_def_local_var ctxt param' in
let ctxt, param =
Name_resolution.add_def_local_var ctxt (Marked.unmark param')
in
let collection = rec_helper collection in
let init =
match Pos.unmark op' with
match Marked.unmark op' with
| Ast.Map | Ast.Filter | Ast.Aggregate (Ast.AggregateArgExtremum _) ->
assert false (* should not happen *)
| Ast.Exists ->
Bindlib.box
(Desugared.Ast.ELit (Dcalc.Ast.LBool false), Pos.get_position op')
(Desugared.Ast.ELit (Dcalc.Ast.LBool false), Marked.get_mark op')
| Ast.Forall ->
Bindlib.box
(Desugared.Ast.ELit (Dcalc.Ast.LBool true), Pos.get_position op')
(Desugared.Ast.ELit (Dcalc.Ast.LBool true), Marked.get_mark op')
| Ast.Aggregate (Ast.AggregateSum Ast.Integer) ->
Bindlib.box
( Desugared.Ast.ELit (Dcalc.Ast.LInt (Runtime.integer_of_int 0)),
Pos.get_position op' )
Marked.get_mark op' )
| Ast.Aggregate (Ast.AggregateSum Ast.Decimal) ->
Bindlib.box
( Desugared.Ast.ELit (Dcalc.Ast.LRat (Runtime.decimal_of_string "0")),
Pos.get_position op' )
Marked.get_mark op' )
| Ast.Aggregate (Ast.AggregateSum Ast.Money) ->
Bindlib.box
( Desugared.Ast.ELit
(Dcalc.Ast.LMoney
(Runtime.money_of_cents_integer (Runtime.integer_of_int 0))),
Pos.get_position op' )
Marked.get_mark op' )
| Ast.Aggregate (Ast.AggregateSum Ast.Duration) ->
Bindlib.box
( Desugared.Ast.ELit
(Dcalc.Ast.LDuration (Runtime.duration_of_numbers 0 0 0)),
Pos.get_position op' )
Marked.get_mark op' )
| Ast.Aggregate (Ast.AggregateSum t) ->
Errors.raise_spanned_error pos
"It is impossible to sum two values of type %a together"
@ -674,16 +676,16 @@ let rec translate_expr
| Ast.Aggregate Ast.AggregateCount ->
Bindlib.box
( Desugared.Ast.ELit (Dcalc.Ast.LInt (Runtime.integer_of_int 0)),
Pos.get_position op' )
Marked.get_mark op' )
in
let acc_var = Desugared.Ast.Var.make ("acc", Pos.get_position param') in
let acc = Desugared.Ast.make_var (acc_var, Pos.get_position param') in
let acc_var = Desugared.Ast.Var.make "acc" in
let acc = Desugared.Ast.make_var (acc_var, Marked.get_mark param') in
let f_body =
let make_body (op : Dcalc.Ast.binop) =
Bindlib.box_apply2
(fun predicate acc ->
( Desugared.Ast.EApp
( (Desugared.Ast.EOp (Dcalc.Ast.Binop op), Pos.get_position op'),
( (Desugared.Ast.EOp (Dcalc.Ast.Binop op), Marked.get_mark op'),
[acc; predicate] ),
pos ))
(translate_expr scope inside_definition_of ctxt predicate)
@ -691,9 +693,9 @@ let rec translate_expr
in
let make_extr_body
(cmp_op : Dcalc.Ast.binop)
(t : Scopelang.Ast.typ Pos.marked) =
let tmp_var = Desugared.Ast.Var.make ("tmp", Pos.get_position param') in
let tmp = Desugared.Ast.make_var (tmp_var, Pos.get_position param') in
(t : Scopelang.Ast.typ Marked.pos) =
let tmp_var = Desugared.Ast.Var.make "tmp" in
let tmp = Desugared.Ast.make_var (tmp_var, Marked.get_mark param') in
Desugared.Ast.make_let_in tmp_var t
(translate_expr scope inside_definition_of ctxt predicate)
(Bindlib.box_apply2
@ -701,7 +703,7 @@ let rec translate_expr
( Desugared.Ast.EIfThenElse
( ( Desugared.Ast.EApp
( ( Desugared.Ast.EOp (Dcalc.Ast.Binop cmp_op),
Pos.get_position op' ),
Marked.get_mark op' ),
[acc; tmp] ),
pos ),
acc,
@ -709,7 +711,7 @@ let rec translate_expr
pos ))
acc tmp)
in
match Pos.unmark op' with
match Marked.unmark op' with
| Ast.Map | Ast.Filter | Ast.Aggregate (Ast.AggregateArgExtremum _) ->
assert false (* should not happen *)
| Ast.Exists -> make_body Dcalc.Ast.Or
@ -751,12 +753,12 @@ let rec translate_expr
( Desugared.Ast.EApp
( ( Desugared.Ast.EOp
(Dcalc.Ast.Binop (Dcalc.Ast.Add Dcalc.Ast.KInt)),
Pos.get_position op' ),
Marked.get_mark op' ),
[
acc;
( Desugared.Ast.ELit
(Dcalc.Ast.LInt (Runtime.integer_of_int 1)),
Pos.get_position predicate );
Marked.get_mark predicate );
] ),
pos ),
acc ),
@ -769,9 +771,9 @@ let rec translate_expr
Bindlib.box_apply
(fun binder ->
( Desugared.Ast.EAbs
( (binder, pos),
( binder,
[
Scopelang.Ast.TLit t, Pos.get_position op';
Scopelang.Ast.TLit t, Marked.get_mark 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
@ -780,7 +782,7 @@ let rec translate_expr
pos ))
(Bindlib.bind_mvar [| acc_var; param |] f_body)
in
match Pos.unmark op' with
match Marked.unmark op' with
| Ast.Map | Ast.Filter | Ast.Aggregate (Ast.AggregateArgExtremum _) ->
assert false (* should not happen *)
| Ast.Exists -> make_f Dcalc.Ast.TBool
@ -810,11 +812,11 @@ let rec translate_expr
pos ))
f collection init
| MemCollection (member, collection) ->
let param_var = Desugared.Ast.Var.make ("collection_member", pos) in
let param_var = Desugared.Ast.Var.make "collection_member" in
let param = Desugared.Ast.make_var (param_var, pos) in
let collection = rec_helper collection in
let init = Bindlib.box (Desugared.Ast.ELit (Dcalc.Ast.LBool false), pos) in
let acc_var = Desugared.Ast.Var.make ("acc", pos) in
let acc_var = Desugared.Ast.Var.make "acc" in
let acc = Desugared.Ast.make_var (acc_var, pos) in
let f_body =
Bindlib.box_apply3
@ -836,7 +838,7 @@ let rec translate_expr
Bindlib.box_apply
(fun binder ->
( Desugared.Ast.EAbs
( (binder, pos),
( binder,
[
Scopelang.Ast.TLit Dcalc.Ast.TBool, pos;
Scopelang.Ast.TAny, pos;
@ -853,6 +855,10 @@ let rec translate_expr
f collection init
| Builtin IntToDec ->
Bindlib.box (Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.IntToRat), pos)
| Builtin MoneyToDec ->
Bindlib.box (Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.MoneyToRat), pos)
| Builtin DecToMoney ->
Bindlib.box (Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.RatToMoney), pos)
| Builtin Cardinal ->
Bindlib.box (Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.Length), pos)
| Builtin GetDay ->
@ -861,6 +867,12 @@ let rec translate_expr
Bindlib.box (Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.GetMonth), pos)
| Builtin GetYear ->
Bindlib.box (Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.GetYear), pos)
| Builtin FirstDayOfMonth ->
Bindlib.box
(Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.FirstDayOfMonth), pos)
| Builtin LastDayOfMonth ->
Bindlib.box
(Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.LastDayOfMonth), pos)
| Builtin RoundMoney ->
Bindlib.box (Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.RoundMoney), pos)
| Builtin RoundDecimal ->
@ -868,31 +880,30 @@ let rec translate_expr
and disambiguate_match_and_build_expression
(scope : Scopelang.Ast.ScopeName.t)
(inside_definition_of : Desugared.Ast.ScopeDef.t Pos.marked option)
(inside_definition_of : Desugared.Ast.ScopeDef.t Marked.pos option)
(ctxt : Name_resolution.context)
(cases : Ast.match_case Pos.marked list) :
Desugared.Ast.expr Pos.marked Bindlib.box Scopelang.Ast.EnumConstructorMap.t
(cases : Ast.match_case Marked.pos list) :
Desugared.Ast.expr Marked.pos Bindlib.box Scopelang.Ast.EnumConstructorMap.t
* Scopelang.Ast.EnumName.t =
let create_var = function
| None -> ctxt, (Desugared.Ast.Var.make ("_", Pos.no_pos), Pos.no_pos)
| None -> ctxt, Desugared.Ast.Var.make "_"
| Some param ->
let ctxt, param_var = Name_resolution.add_def_local_var ctxt param in
ctxt, (param_var, Pos.get_position param)
ctxt, param_var
in
let bind_case_body
(c_uid : Dcalc.Ast.EnumConstructor.t)
(e_uid : Dcalc.Ast.EnumName.t)
(ctxt : Name_resolution.context)
(param_pos : Pos.t)
(case_body : ('a * Pos.t) Bindlib.box)
(e_binder :
(Desugared.Ast.expr, Desugared.Ast.expr * Pos.t) Bindlib.mbinder
Bindlib.box) : 'c Bindlib.box =
Bindlib.box_apply2
(fun e_binder case_body ->
Pos.same_pos_as
Marked.same_mark_as
(Desugared.Ast.EAbs
( (e_binder, param_pos),
( e_binder,
[
Scopelang.Ast.EnumConstructorMap.find c_uid
(Scopelang.Ast.EnumMap.find e_uid ctxt.Name_resolution.enums);
@ -903,10 +914,10 @@ and disambiguate_match_and_build_expression
let bind_match_cases (cases_d, e_uid, curr_index) (case, case_pos) =
match case with
| Ast.MatchCase case ->
let constructor, binding = Pos.unmark case.Ast.match_case_pattern in
let constructor, binding = Marked.unmark case.Ast.match_case_pattern in
let e_uid', c_uid =
disambiguate_constructor ctxt constructor
(Pos.get_position case.Ast.match_case_pattern)
(Marked.get_mark case.Ast.match_case_pattern)
in
let e_uid =
match e_uid with
@ -915,7 +926,7 @@ and disambiguate_match_and_build_expression
if e_uid = e_uid' then e_uid
else
Errors.raise_spanned_error
(Pos.get_position case.Ast.match_case_pattern)
(Marked.get_mark case.Ast.match_case_pattern)
"This case matches a constructor of enumeration %a but previous \
case were matching constructors of enumeration %a"
Scopelang.Ast.EnumName.format_t e_uid
@ -926,19 +937,17 @@ and disambiguate_match_and_build_expression
| Some e_case ->
Errors.raise_multispanned_error
[
None, Pos.get_position case.match_case_expr;
None, Pos.get_position (Bindlib.unbox e_case);
None, Marked.get_mark case.match_case_expr;
None, Marked.get_mark (Bindlib.unbox e_case);
]
"The constructor %a has been matched twice:"
Scopelang.Ast.EnumConstructor.format_t c_uid);
let ctxt, (param_var, param_pos) = create_var binding in
let ctxt, param_var = create_var (Option.map Marked.unmark binding) in
let case_body =
translate_expr scope inside_definition_of ctxt case.Ast.match_case_expr
in
let e_binder = Bindlib.bind_mvar (Array.of_list [param_var]) case_body in
let case_expr =
bind_case_body c_uid e_uid ctxt param_pos case_body e_binder
in
let case_expr = bind_case_body c_uid e_uid ctxt case_body e_binder in
( Scopelang.Ast.EnumConstructorMap.add c_uid case_expr cases_d,
Some e_uid,
curr_index + 1 )
@ -949,7 +958,7 @@ and disambiguate_match_and_build_expression
[
Some "Not ending wildcard:", case_pos;
( Some "Next reachable case:",
curr_index + 1 |> List.nth cases |> Pos.get_position );
curr_index + 1 |> List.nth cases |> Marked.get_mark );
]
"Wildcard must be the last match case"
in
@ -988,7 +997,7 @@ and disambiguate_match_and_build_expression
...
| CaseN -> wildcard_payload *)
(* Creates the wildcard payload *)
let ctxt, (payload_var, var_pos) = create_var None in
let ctxt, payload_var = create_var None in
let case_body =
translate_expr scope inside_definition_of ctxt match_case_expr
in
@ -1000,7 +1009,7 @@ and disambiguate_match_and_build_expression
Scopelang.Ast.EnumConstructorMap.fold
(fun c_uid _ (cases_d, e_uid_opt, curr_index) ->
let case_expr =
bind_case_body c_uid e_uid ctxt var_pos case_body e_binder
bind_case_body c_uid e_uid ctxt case_body e_binder
in
( Scopelang.Ast.EnumConstructorMap.add c_uid case_expr cases_d,
e_uid_opt,
@ -1022,21 +1031,23 @@ and disambiguate_match_and_build_expression
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 : Desugared.Ast.expr Pos.marked Bindlib.box option)
(cond : Desugared.Ast.expr Pos.marked Bindlib.box option)
(default_pos : Pos.t) : Desugared.Ast.expr Pos.marked Bindlib.box =
(precond : Desugared.Ast.expr Marked.pos Bindlib.box option)
(cond : Desugared.Ast.expr Marked.pos Bindlib.box option)
(default_pos : Pos.t) : Desugared.Ast.expr Marked.pos Bindlib.box =
match precond, cond with
| Some precond, Some cond ->
let op_term =
( Desugared.Ast.EOp (Dcalc.Ast.Binop Dcalc.Ast.And),
Pos.get_position (Bindlib.unbox cond) )
Marked.get_mark (Bindlib.unbox cond) )
in
Bindlib.box_apply2
(fun precond cond ->
Desugared.Ast.EApp (op_term, [precond; cond]), Pos.get_position cond)
Desugared.Ast.EApp (op_term, [precond; cond]), Marked.get_mark cond)
precond cond
| Some precond, None ->
Bindlib.box_apply (fun precond -> Pos.unmark precond, default_pos) precond
Bindlib.box_apply
(fun precond -> Marked.unmark precond, default_pos)
precond
| None, Some cond -> cond
| None, None ->
Bindlib.box (Desugared.Ast.ELit (Dcalc.Ast.LBool true), default_pos)
@ -1046,47 +1057,49 @@ let merge_conditions
let process_default
(ctxt : Name_resolution.context)
(scope : Scopelang.Ast.ScopeName.t)
(def_key : Desugared.Ast.ScopeDef.t Pos.marked)
(def_key : Desugared.Ast.ScopeDef.t Marked.pos)
(rule_id : Desugared.Ast.RuleName.t)
(param_uid : Desugared.Ast.Var.t Pos.marked option)
(precond : Desugared.Ast.expr Pos.marked Bindlib.box option)
(exception_to_rules : Desugared.Ast.RuleSet.t Pos.marked)
(just : Ast.expression Pos.marked option)
(cons : Ast.expression Pos.marked) : Desugared.Ast.rule =
(param_uid : Desugared.Ast.Var.t Marked.pos option)
(precond : Desugared.Ast.expr Marked.pos Bindlib.box option)
(exception_situation : Desugared.Ast.exception_situation)
(label_situation : Desugared.Ast.label_situation)
(just : Ast.expression Marked.pos option)
(cons : Ast.expression Marked.pos) : Desugared.Ast.rule =
let just =
match just with
| Some just -> Some (translate_expr scope (Some def_key) ctxt just)
| None -> None
in
let just = merge_conditions precond just (Pos.get_position def_key) in
let just = merge_conditions precond just (Marked.get_mark def_key) in
let cons = translate_expr scope (Some def_key) ctxt cons in
{
rule_just = just;
rule_cons = cons;
rule_parameter =
(let def_key_typ =
Name_resolution.get_def_typ ctxt (Pos.unmark def_key)
Name_resolution.get_def_typ ctxt (Marked.unmark def_key)
in
match Pos.unmark def_key_typ, param_uid with
match Marked.unmark def_key_typ, param_uid with
| Scopelang.Ast.TArrow (t_in, _), Some param_uid ->
Some (Pos.unmark param_uid, t_in)
Some (Marked.unmark param_uid, t_in)
| Scopelang.Ast.TArrow _, None ->
Errors.raise_spanned_error
(Pos.get_position (Bindlib.unbox cons))
(Marked.get_mark (Bindlib.unbox cons))
"This definition has a function type but the parameter is missing"
| _, Some _ ->
Errors.raise_spanned_error
(Pos.get_position (Bindlib.unbox cons))
(Marked.get_mark (Bindlib.unbox cons))
"This definition has a parameter but its type is not a function"
| _ -> None);
rule_exception_to_rules = exception_to_rules;
rule_exception = exception_situation;
rule_id;
rule_label = label_situation;
}
(** Wrapper around {!val: process_default} that performs some name
disambiguation *)
let process_def
(precond : Desugared.Ast.expr Pos.marked Bindlib.box option)
(precond : Desugared.Ast.expr Marked.pos Bindlib.box option)
(scope_uid : Scopelang.Ast.ScopeName.t)
(ctxt : Name_resolution.context)
(prgm : Desugared.Ast.program)
@ -1097,9 +1110,9 @@ let process_def
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
let def_key =
Name_resolution.get_def_key
(Pos.unmark def.definition_name)
(Marked.unmark def.definition_name)
def.definition_state scope_uid ctxt
(Pos.get_position def.definition_expr)
(Marked.get_mark def.definition_expr)
in
let scope_def_ctxt =
Desugared.Ast.ScopeDefMap.find def_key scope_ctxt.scope_defs_contexts
@ -1109,36 +1122,45 @@ let process_def
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
let ctxt, param_var =
Name_resolution.add_def_local_var ctxt (Marked.unmark param)
in
Some (Marked.same_mark_as param_var param), ctxt
in
let scope_updated =
let scope_def = Desugared.Ast.ScopeDefMap.find def_key scope.scope_defs in
let rule_name = def.definition_id in
let parent_rules =
let label_situation =
match def.definition_label with
| Some (label_str, label_pos) ->
Desugared.Ast.ExplicitlyLabeled
( Desugared.Ast.IdentMap.find label_str scope_def_ctxt.label_idmap,
label_pos )
| None -> Desugared.Ast.Unlabeled
in
let exception_situation =
match def.Ast.definition_exception_to with
| NotAnException ->
Desugared.Ast.RuleSet.empty, Pos.get_position def.Ast.definition_name
| NotAnException -> Desugared.Ast.BaseCase
| UnlabeledException -> (
match scope_def_ctxt.default_exception_rulename with
(* This should have been caught previously by
check_unlabeled_exception *)
| None | Some (Name_resolution.Ambiguous _) ->
(* This should have been caught previously by
check_unlabeled_exception *)
assert false (* should not happen *)
| Some (Name_resolution.Unique (name, pos)) ->
Desugared.Ast.RuleSet.singleton name, pos)
| ExceptionToLabel label -> (
Desugared.Ast.ExceptionToRule (name, pos))
| ExceptionToLabel label_str -> (
try
let label_id =
Desugared.Ast.IdentMap.find (Pos.unmark label)
Desugared.Ast.IdentMap.find (Marked.unmark label_str)
scope_def_ctxt.label_idmap
in
( Desugared.Ast.LabelMap.find label_id scope_def.scope_def_label_groups,
Pos.get_position def.Ast.definition_name )
Desugared.Ast.ExceptionToLabel (label_id, Marked.get_mark label_str)
with Not_found ->
Errors.raise_spanned_error (Pos.get_position label)
Errors.raise_spanned_error
(Marked.get_mark label_str)
"Unknown label for the scope variable %a: \"%s\""
Desugared.Ast.ScopeDef.format_t def_key (Pos.unmark label))
Desugared.Ast.ScopeDef.format_t def_key (Marked.unmark label_str))
in
let scope_def =
{
@ -1146,9 +1168,9 @@ let process_def
scope_def_rules =
Desugared.Ast.RuleMap.add rule_name
(process_default new_ctxt scope_uid
(def_key, Pos.get_position def.definition_name)
rule_name param_uid precond parent_rules def.definition_condition
def.definition_expr)
(def_key, Marked.get_mark def.definition_name)
rule_name param_uid precond exception_situation label_situation
def.definition_condition def.definition_expr)
scope_def.scope_def_rules;
}
in
@ -1166,7 +1188,7 @@ let process_def
(** Translates a {!type: Surface.Ast.rule} from the surface language *)
let process_rule
(precond : Desugared.Ast.expr Pos.marked Bindlib.box option)
(precond : Desugared.Ast.expr Marked.pos Bindlib.box option)
(scope : Scopelang.Ast.ScopeName.t)
(ctxt : Name_resolution.context)
(prgm : Desugared.Ast.program)
@ -1176,7 +1198,7 @@ let process_rule
(** Translates assertions *)
let process_assert
(precond : Desugared.Ast.expr Pos.marked Bindlib.box option)
(precond : Desugared.Ast.expr Marked.pos Bindlib.box option)
(scope_uid : Scopelang.Ast.ScopeName.t)
(ctxt : Name_resolution.context)
(prgm : Desugared.Ast.program)
@ -1192,8 +1214,8 @@ let process_assert
( Ast.IfThenElse
( cond,
ass.Ast.assertion_content,
Pos.same_pos_as (Ast.Literal (Ast.LBool true)) cond ),
Pos.get_position cond ))
Marked.same_mark_as (Ast.Literal (Ast.LBool true)) cond ),
Marked.get_mark cond ))
in
let ass =
match precond with
@ -1203,9 +1225,9 @@ let process_assert
( Desugared.Ast.EIfThenElse
( precond,
ass,
Pos.same_pos_as (Desugared.Ast.ELit (Dcalc.Ast.LBool true))
Marked.same_mark_as (Desugared.Ast.ELit (Dcalc.Ast.LBool true))
precond ),
Pos.get_position precond ))
Marked.get_mark precond ))
precond ass
| None -> ass
in
@ -1220,13 +1242,13 @@ let process_assert
(** Translates a surface definition, rule or assertion *)
let process_scope_use_item
(precond : Ast.expression Pos.marked option)
(precond : Ast.expression Marked.pos option)
(scope : Scopelang.Ast.ScopeName.t)
(ctxt : Name_resolution.context)
(prgm : Desugared.Ast.program)
(item : Ast.scope_use_item Pos.marked) : Desugared.Ast.program =
(item : Ast.scope_use_item Marked.pos) : Desugared.Ast.program =
let precond = Option.map (translate_expr scope None ctxt) precond in
match Pos.unmark item with
match Marked.unmark item with
| Ast.Rule rule -> process_rule precond scope ctxt prgm rule
| Ast.Definition def -> process_def precond scope ctxt prgm def
| Ast.Assertion ass -> process_assert precond scope ctxt prgm ass
@ -1239,23 +1261,23 @@ let process_scope_use_item
let check_unlabeled_exception
(scope : Scopelang.Ast.ScopeName.t)
(ctxt : Name_resolution.context)
(item : Ast.scope_use_item Pos.marked) : unit =
(item : Ast.scope_use_item Marked.pos) : unit =
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope ctxt.scopes in
match Pos.unmark item with
match Marked.unmark item with
| Ast.Rule _ | Ast.Definition _ -> (
let def_key, exception_to =
match Pos.unmark item with
match Marked.unmark item with
| Ast.Rule rule ->
( Name_resolution.get_def_key
(Pos.unmark rule.rule_name)
(Marked.unmark rule.rule_name)
rule.rule_state scope ctxt
(Pos.get_position rule.rule_name),
(Marked.get_mark rule.rule_name),
rule.rule_exception_to )
| Ast.Definition def ->
( Name_resolution.get_def_key
(Pos.unmark def.definition_name)
(Marked.unmark def.definition_name)
def.definition_state scope ctxt
(Pos.get_position def.definition_name),
(Marked.get_mark def.definition_name),
def.definition_exception_to )
| _ -> assert false
(* should not happen *)
@ -1270,11 +1292,11 @@ let check_unlabeled_exception
| Ast.UnlabeledException -> (
match scope_def_ctxt.default_exception_rulename with
| None ->
Errors.raise_spanned_error (Pos.get_position item)
Errors.raise_spanned_error (Marked.get_mark item)
"This exception does not have a corresponding definition"
| Some (Ambiguous pos) ->
Errors.raise_multispanned_error
([Some "Ambiguous exception", Pos.get_position item]
([Some "Ambiguous exception", Marked.get_mark item]
@ List.map (fun p -> Some "Candidate definition", p) pos)
"This exception can refer to several definitions. Try using labels \
to disambiguate"
@ -1305,7 +1327,7 @@ let attribute_to_io (attr : Ast.scope_decl_context_io) : Scopelang.Ast.io =
{
Scopelang.Ast.io_output = attr.scope_decl_context_io_output;
Scopelang.Ast.io_input =
Pos.map_under_mark
Marked.map_under_mark
(fun io ->
match io with
| Ast.Input -> Scopelang.Ast.OnlyInput
@ -1363,8 +1385,6 @@ let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) :
Desugared.Ast.scope_def_rules =
Desugared.Ast.RuleMap.empty;
Desugared.Ast.scope_def_typ = v_sig.var_sig_typ;
Desugared.Ast.scope_def_label_groups =
Name_resolution.label_groups ctxt s_uid def_key;
Desugared.Ast.scope_def_is_condition =
v_sig.var_sig_is_condition;
Desugared.Ast.scope_def_io =
@ -1384,9 +1404,6 @@ let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) :
Desugared.Ast.RuleMap.empty;
Desugared.Ast.scope_def_typ =
v_sig.var_sig_typ;
Desugared.Ast.scope_def_label_groups =
Name_resolution.label_groups ctxt s_uid
def_key;
Desugared.Ast.scope_def_is_condition =
v_sig.var_sig_is_condition;
Desugared.Ast.scope_def_io =
@ -1403,7 +1420,7 @@ let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) :
if i = 0 then original_io.io_input
else
( Scopelang.Ast.NoInput,
Pos.get_position
Marked.get_mark
(Desugared.Ast.StateName
.get_info state) )
in
@ -1412,7 +1429,7 @@ let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) :
original_io.io_output
else
( false,
Pos.get_position
Marked.get_mark
(Desugared.Ast.StateName
.get_info state) )
in
@ -1442,9 +1459,6 @@ let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) :
Desugared.Ast.scope_def_rules =
Desugared.Ast.RuleMap.empty;
Desugared.Ast.scope_def_typ = v_sig.var_sig_typ;
Desugared.Ast.scope_def_label_groups =
Name_resolution.label_groups ctxt subscope_uid
def_key;
Desugared.Ast.scope_def_is_condition =
v_sig.var_sig_is_condition;
Desugared.Ast.scope_def_io =
@ -1475,7 +1489,7 @@ let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) :
| CodeBlock (block, _, _) ->
List.fold_left
(fun prgm item ->
match Pos.unmark item with
match Marked.unmark item with
| Ast.ScopeUse use -> process_scope_use ctxt prgm use
| _ -> prgm)
prgm block

7
compiler/surface/dune
View File

@ -10,7 +10,7 @@
scopelang
zarith
zarith_stubs_js
calendar)
dates_calc)
(preprocess
(pps sedlex.ppx visitors.ppx)))
@ -38,6 +38,11 @@
(merge_into parser)
(flags --external-tokens Tokens --table --explain))
(rule
(target grammar.html)
(action
(run obelisk html -o %{target} %{dep:parser.mly})))
(documentation
(package catala)
(mld_files surface))

6
compiler/surface/fill_positions.ml
View File

@ -21,14 +21,14 @@ let fill_pos_with_legislative_info (p : Ast.program) : Ast.program =
object
inherit [_] Ast.program_map as super
method! visit_marked f env x =
f env (Pos.unmark x), Pos.overwrite_law_info (Pos.get_position x) env
method! visit_pos f env x =
f env (Marked.unmark x), Pos.overwrite_law_info (Marked.get_mark x) env
method! visit_LawHeading
(env : string list)
(heading : Ast.law_heading)
(children : Ast.law_structure list) =
let env = Pos.unmark heading.law_heading_name :: env in
let env = Marked.unmark heading.law_heading_name :: env in
Ast.LawHeading
( super#visit_law_heading env heading,
List.map (fun child -> super#visit_law_structure env child) children

45
compiler/surface/lexer.cppo.ml
View File

@ -59,6 +59,9 @@ module R = Re.Pcre
#ifndef MR_COLLECTION
#define MR_COLLECTION MS_COLLECTION
#endif
#ifndef MR_CONTAINS
#define MR_CONTAINS MS_CONTAINS
#endif
#ifndef MR_ENUM
#define MR_ENUM MS_ENUM
#endif
@ -221,6 +224,12 @@ module R = Re.Pcre
#ifndef MR_IntToDec
#define MR_IntToDec MS_IntToDec
#endif
#ifndef MR_MoneyToDec
#define MR_MoneyToDec MS_MoneyToDec
#endif
#ifndef MR_DecToMoney
#define MR_DecToMoney MS_DecToMoney
#endif
#ifndef MR_RoundMoney
#define MR_RoundMoney MS_RoundMoney
#endif
@ -236,6 +245,12 @@ module R = Re.Pcre
#ifndef MR_GetYear
#define MR_GetYear MS_GetYear
#endif
#ifndef MR_FirstDayOfMonth
#define MR_FirstDayOfMonth MS_FirstDayOfMonth
#endif
#ifndef MR_LastDayOfMonth
#define MR_LastDayOfMonth MS_LastDayOfMonth
#endif
#ifndef MR_INPUT
#define MR_INPUT MS_INPUT
#endif
@ -258,6 +273,7 @@ let token_list : (string * token) list =
(MS_INCREASING, INCREASING);
(MS_OF, OF);
(MS_COLLECTION, COLLECTION);
(MS_CONTAINS, CONTAINS);
(MS_ENUM, ENUM);
(MS_INTEGER, INTEGER);
(MS_MONEY, MONEY);
@ -322,9 +338,13 @@ let lex_builtin (s : string) : Ast.builtin_expression option =
let lexbuf = Utf8.from_string s in
match%sedlex lexbuf with
| MR_IntToDec, eof -> Some IntToDec
| MR_DecToMoney, eof -> Some DecToMoney
| MR_MoneyToDec, eof -> Some MoneyToDec
| MR_GetDay, eof -> Some GetDay
| MR_GetMonth, eof -> Some GetMonth
| MR_GetYear, eof -> Some GetYear
| MR_FirstDayOfMonth -> Some FirstDayOfMonth
| MR_LastDayOfMonth -> Some LastDayOfMonth
| MR_RoundMoney, eof -> Some RoundMoney
| MR_RoundDecimal, eof -> Some RoundDecimal
| _ -> None
@ -394,6 +414,9 @@ let rec lex_code (lexbuf : lexbuf) : token =
| MR_COLLECTION ->
L.update_acc lexbuf;
COLLECTION
| MR_CONTAINS ->
L.update_acc lexbuf;
CONTAINS
| MR_ENUM ->
L.update_acc lexbuf;
ENUM
@ -572,10 +595,26 @@ let rec lex_code (lexbuf : lexbuf) : token =
Buffer.add_string cents (String.make (2 - Buffer.length cents) '0');
L.update_acc lexbuf;
MONEY_AMOUNT (Buffer.contents units, Buffer.contents cents)
| Plus digit, MC_DECIMAL_SEPARATOR, Star digit ->
| Rep (digit, 4), '-', Rep (digit, 2), '-', Rep (digit, 2) ->
let rex =
Re.(compile @@ whole_string @@ seq [
group (rep1 digit);
group (repn digit 4 None);
char '-';
group (repn digit 2 None);
char '-';
group (repn digit 2 None);
])
in
let date_parts = R.get_substring (R.exec ~rex (Utf8.lexeme lexbuf)) in
DATE_LITERAL (
int_of_string (date_parts 1),
int_of_string (date_parts 2),
int_of_string (date_parts 3)
)
| Opt '-', Plus digit, MC_DECIMAL_SEPARATOR, Star digit ->
let rex =
Re.(compile @@ whole_string @@ seq [
group (seq [opt (char '-') ; rep1 digit]);
char MC_DECIMAL_SEPARATOR;
group (rep digit)
]) in
@ -750,7 +789,7 @@ let rec lex_code (lexbuf : lexbuf) : token =
(* Name of variable *)
L.update_acc lexbuf;
IDENT (Utf8.lexeme lexbuf)
| Plus digit ->
| Opt '-', Plus digit ->
(* Integer literal*)
L.update_acc lexbuf;
INT_LITERAL (Utf8.lexeme lexbuf)

5
compiler/surface/lexer_en.cppo.ml
View File

@ -29,6 +29,7 @@
#define MS_INCREASING "increasing"
#define MS_OF "of"
#define MS_COLLECTION "collection"
#define MS_CONTAINS "contains"
#define MS_ENUM "enumeration"
#define MS_INTEGER "integer"
#define MS_MONEY "money"
@ -102,9 +103,13 @@
#define MS_RoundMoney "round_money"
#define MS_RoundDecimal "round_decimal"
#define MS_IntToDec "integer_to_decimal"
#define MS_MoneyToDec "money_to_decimal"
#define MS_DecToMoney "decimal_to_money"
#define MS_GetDay "get_day"
#define MS_GetMonth "get_month"
#define MS_GetYear "get_year"
#define MS_FirstDayOfMonth "first_day_of_month"
#define MS_LastDayOfMonth "last_day_of_month"
(* Directives *)

7
compiler/surface/lexer_fr.cppo.ml
View File

@ -37,6 +37,7 @@
#define MS_INCREASING "croissant"
#define MS_OF "de"
#define MS_COLLECTION "collection"
#define MS_CONTAINS "contient"
#define MS_ENUM "énumération"
#define MR_ENUM 0xE9, "num", 0xE9, "ration"
#define MS_INTEGER "entier"
@ -125,12 +126,18 @@
#define MR_RoundDecimal "arrondi_d", 0xE9, "cimal"
#define MS_IntToDec "entier_vers_décimal"
#define MR_IntToDec "entier_vers_d", 0xE9, "cimal"
#define MS_MoneyToDec "argent_vers_décimal"
#define MR_MoneyToDec "argent_vers_d", 0xE9, "cimal"
#define MS_DecToMoney "décimal_vers_argent"
#define MR_DecToMoney "d", 0xE9, "cimal_vers_argent"
#define MS_GetDay "accès_jour"
#define MR_GetDay "acc", 0xE8, "s_jour"
#define MS_GetMonth "accès_mois"
#define MR_GetMonth "acc", 0xE8, "s_mois"
#define MS_GetYear "accès_année"
#define MR_GetYear "acc", 0xE8, "s_ann", 0xE9, "e"
#define MS_FirstDayOfMonth "premier_jour_du_mois"
#define MS_LastDayOfMonth "dernier_jour_du_mois"
(* Directives *)

9
compiler/surface/lexer_pl.cppo.ml
View File

@ -29,6 +29,7 @@
#define MS_INCREASING "rosnacy"
#define MS_OF "z"
#define MS_COLLECTION "kolekcja"
#define MS_CONTAINS "zawiera"
#define MS_ENUM "enumeracja"
#define MS_INTEGER "calkowita"
#define MS_MONEY "pieniądze"
@ -113,12 +114,20 @@
#define MR_RoundMoney "zaokr",0x0105,"glony_pieni", 0x0105, "dze"
#define MS_IntToDec "calkowita_wers_dziesiętny"
#define MR_IntToDec "calkowita_wers_dziesi", 0x0119, "tny"
#define MS_MoneyToDec "pieniądze_wers_dziesiętny"
#define MR_MoneyToDec "pieni", 0x0105, "dze_wers_dziesi", 0x0119, "tny"
#define MS_DecToMoney "dziesiętny_wers_pieniądze"
#define MR_DecToMoney "dziesi", 0x0119, "tny_wers_pieni", 0x0105, "dze"
#define MS_GetDay "dostęp_dzień"
#define MR_GetDay "dost", 0x0119, "p_dzie", 0x144
#define MS_GetMonth "dostęp_miesiąc"
#define MR_GetMonth "dost", 0x0119, "p_miesi", 0x0105, "c"
#define MS_GetYear "dostęp_rok"
#define MR_GetYear "dost", 0x0119, "p_rok"
#define MS_FirstDayOfMonth "pierwszy_dzień_miesiąca"
#define MR_FirstDayOfMonth "pierwszy_dzie", 0x144, "_miesi", 0x0105, "ca"
#define MS_LastDayOfMonth "ostatni_dzień_miesiąca"
#define MR_LastDayOfMonth "ostatni_dzie", 0x144, "_miesi", 0x0105, "ca"
(* Directives *)

151
compiler/surface/name_resolution.ml
View File

@ -27,12 +27,11 @@ type typ = Scopelang.Ast.typ
type unique_rulename =
| Ambiguous of Pos.t list
| Unique of Desugared.Ast.RuleName.t Pos.marked
| Unique of Desugared.Ast.RuleName.t Marked.pos
type scope_def_context = {
default_exception_rulename : unique_rulename option;
label_idmap : Desugared.Ast.LabelName.t Desugared.Ast.IdentMap.t;
label_groups : Desugared.Ast.RuleSet.t Desugared.Ast.LabelMap.t;
}
type scope_context = {
@ -47,14 +46,14 @@ type scope_context = {
}
(** Inside a scope, we distinguish between the variables and the subscopes. *)
type struct_context = typ Pos.marked Scopelang.Ast.StructFieldMap.t
type struct_context = typ Marked.pos Scopelang.Ast.StructFieldMap.t
(** Types of the fields of a struct *)
type enum_context = typ Pos.marked Scopelang.Ast.EnumConstructorMap.t
type enum_context = typ Marked.pos Scopelang.Ast.EnumConstructorMap.t
(** Types of the payloads of the cases of an enum *)
type var_sig = {
var_sig_typ : typ Pos.marked;
var_sig_typ : typ Marked.pos;
var_sig_is_condition : bool;
var_sig_io : Ast.scope_decl_context_io;
var_sig_states_idmap : Desugared.Ast.StateName.t Desugared.Ast.IdentMap.t;
@ -101,15 +100,15 @@ let raise_unsupported_feature (msg : string) (pos : Pos.t) =
(** 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 (Pos.get_position ident)
let raise_unknown_identifier (msg : string) (ident : ident Marked.pos) =
Errors.raise_spanned_error (Marked.get_mark ident)
"\"%s\": unknown identifier %s"
(Utils.Cli.with_style [ANSITerminal.yellow] "%s" (Pos.unmark ident))
(Utils.Cli.with_style [ANSITerminal.yellow] "%s" (Marked.unmark ident))
msg
(** Gets the type associated to an uid *)
let get_var_typ (ctxt : context) (uid : Desugared.Ast.ScopeVar.t) :
typ Pos.marked =
typ Marked.pos =
(Desugared.Ast.ScopeVarMap.find uid ctxt.var_typs).var_sig_typ
let is_var_cond (ctxt : context) (uid : Desugared.Ast.ScopeVar.t) : bool =
@ -123,7 +122,7 @@ let get_var_io (ctxt : context) (uid : Desugared.Ast.ScopeVar.t) :
let get_var_uid
(scope_uid : Scopelang.Ast.ScopeName.t)
(ctxt : context)
((x, pos) : ident Pos.marked) : Desugared.Ast.ScopeVar.t =
((x, pos) : ident Marked.pos) : Desugared.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 ->
@ -137,7 +136,7 @@ let get_var_uid
let get_subscope_uid
(scope_uid : Scopelang.Ast.ScopeName.t)
(ctxt : context)
((y, pos) : ident Pos.marked) : Scopelang.Ast.SubScopeName.t =
((y, pos) : ident Marked.pos) : 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)
@ -164,7 +163,7 @@ let belongs_to
(** Retrieves the type of a scope definition from the context *)
let get_def_typ (ctxt : context) (def : Desugared.Ast.ScopeDef.t) :
typ Pos.marked =
typ Marked.pos =
match def with
| Desugared.Ast.ScopeDef.SubScopeVar (_, x)
(* we don't need to look at the subscope prefix because [x] is already the uid
@ -180,17 +179,6 @@ let is_def_cond (ctxt : context) (def : Desugared.Ast.ScopeDef.t) : bool =
| Desugared.Ast.ScopeDef.Var (x, _) ->
is_var_cond ctxt x
let label_groups
(ctxt : context)
(s_uid : Scopelang.Ast.ScopeName.t)
(def : Desugared.Ast.ScopeDef.t) :
Desugared.Ast.RuleSet.t Desugared.Ast.LabelMap.t =
try
(Desugared.Ast.ScopeDefMap.find def
(Scopelang.Ast.ScopeMap.find s_uid ctxt.scopes).scope_defs_contexts)
.label_groups
with Not_found -> Desugared.Ast.LabelMap.empty
(** {1 Declarations pass} *)
(** Process a subscope declaration *)
@ -208,7 +196,7 @@ let process_subscope_decl
Errors.raise_multispanned_error
[
( Some "first use",
Pos.get_position (Scopelang.Ast.SubScopeName.get_info use) );
Marked.get_mark (Scopelang.Ast.SubScopeName.get_info use) );
Some "second use", s_pos;
]
"Subscope name \"%a\" already used"
@ -237,7 +225,7 @@ let process_subscope_decl
scopes = Scopelang.Ast.ScopeMap.add scope scope_ctxt ctxt.scopes;
}
let is_type_cond ((typ, _) : Ast.typ Pos.marked) =
let is_type_cond ((typ, _) : Ast.typ Marked.pos) =
match typ with
| Ast.Base Ast.Condition
| Ast.Func { arg_typ = _; return_typ = Ast.Condition, _ } ->
@ -247,13 +235,14 @@ let is_type_cond ((typ, _) : Ast.typ Pos.marked) =
(** 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 =
((typ, typ_pos) : Ast.base_typ Marked.pos) : Scopelang.Ast.typ Marked.pos =
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))),
(Marked.unmark
(process_base_typ ctxt
(Ast.Data (Marked.unmark t), Marked.get_mark t))),
typ_pos )
| Ast.Data (Ast.Primitive prim) -> (
match prim with
@ -277,8 +266,8 @@ let rec process_base_typ
ident)))
(** Process a type (function or not) *)
let process_type (ctxt : context) ((typ, typ_pos) : Ast.typ Pos.marked) :
Scopelang.Ast.typ Pos.marked =
let process_type (ctxt : context) ((typ, typ_pos) : Ast.typ Marked.pos) :
Scopelang.Ast.typ Marked.pos =
match typ with
| Ast.Base base_typ -> process_base_typ ctxt (base_typ, typ_pos)
| Ast.Func { arg_typ; return_typ } ->
@ -300,7 +289,7 @@ let process_data_decl
| Some use ->
Errors.raise_multispanned_error
[
Some "First use:", Pos.get_position (Desugared.Ast.ScopeVar.get_info use);
Some "First use:", Marked.get_mark (Desugared.Ast.ScopeVar.get_info use);
Some "Second use:", pos;
]
"Variable name \"%a\" already used"
@ -318,7 +307,7 @@ let process_data_decl
List.fold_right
(fun state_id (states_idmap, states_list) ->
let state_uid = Desugared.Ast.StateName.fresh state_id in
( Desugared.Ast.IdentMap.add (Pos.unmark state_id) state_uid
( Desugared.Ast.IdentMap.add (Marked.unmark state_id) state_uid
states_idmap,
state_uid :: states_list ))
decl.scope_decl_context_item_states
@ -349,15 +338,14 @@ let process_item_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) (name : ident Pos.marked) :
let add_def_local_var (ctxt : context) (name : ident) :
context * Desugared.Ast.Var.t =
let local_var_uid = Desugared.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;
Desugared.Ast.IdentMap.add name local_var_uid ctxt.local_var_idmap;
}
in
ctxt, local_var_uid
@ -367,7 +355,7 @@ let process_scope_decl (ctxt : context) (decl : Ast.scope_decl) : context =
let name, _ = decl.scope_decl_name in
let scope_uid = Desugared.Ast.IdentMap.find name ctxt.scope_idmap in
List.fold_left
(fun ctxt item -> process_item_decl scope_uid ctxt (Pos.unmark item))
(fun ctxt item -> process_item_decl scope_uid ctxt (Marked.unmark item))
ctxt decl.scope_decl_context
(** Process a struct declaration *)
@ -377,10 +365,10 @@ let process_struct_decl (ctxt : context) (sdecl : Ast.struct_decl) : context =
in
if List.length sdecl.struct_decl_fields = 0 then
Errors.raise_spanned_error
(Pos.get_position sdecl.struct_decl_name)
(Marked.get_mark sdecl.struct_decl_name)
"The struct %s does not have any fields; give it some for Catala to be \
able to accept it."
(Pos.unmark sdecl.struct_decl_name);
(Marked.unmark sdecl.struct_decl_name);
List.fold_left
(fun ctxt (fdecl, _) ->
let f_uid =
@ -391,7 +379,7 @@ let process_struct_decl (ctxt : context) (sdecl : Ast.struct_decl) : context =
ctxt with
field_idmap =
Desugared.Ast.IdentMap.update
(Pos.unmark fdecl.Ast.struct_decl_field_name)
(Marked.unmark fdecl.Ast.struct_decl_field_name)
(fun uids ->
match uids with
| None -> Some (Scopelang.Ast.StructMap.singleton s_uid f_uid)
@ -426,10 +414,10 @@ let process_enum_decl (ctxt : context) (edecl : Ast.enum_decl) : context =
in
if List.length edecl.enum_decl_cases = 0 then
Errors.raise_spanned_error
(Pos.get_position edecl.enum_decl_name)
(Marked.get_mark edecl.enum_decl_name)
"The enum %s does not have any cases; give it some for Catala to be able \
to accept it."
(Pos.unmark edecl.enum_decl_name);
(Marked.unmark edecl.enum_decl_name);
List.fold_left
(fun ctxt (cdecl, cdecl_pos) ->
let c_uid =
@ -440,7 +428,7 @@ let process_enum_decl (ctxt : context) (edecl : Ast.enum_decl) : context =
ctxt with
constructor_idmap =
Desugared.Ast.IdentMap.update
(Pos.unmark cdecl.Ast.enum_decl_case_name)
(Marked.unmark cdecl.Ast.enum_decl_case_name)
(fun uids ->
match uids with
| None -> Some (Scopelang.Ast.EnumMap.singleton e_uid c_uid)
@ -468,19 +456,19 @@ let process_enum_decl (ctxt : context) (edecl : Ast.enum_decl) : context =
ctxt edecl.enum_decl_cases
(** Process the names of all declaration items *)
let process_name_item (ctxt : context) (item : Ast.code_item Pos.marked) :
let process_name_item (ctxt : context) (item : Ast.code_item Marked.pos) :
context =
let raise_already_defined_error (use : Uid.MarkedString.info) name pos msg =
Errors.raise_multispanned_error
[
Some "First definition:", Pos.get_position use;
Some "First definition:", Marked.get_mark use;
Some "Second definition:", pos;
]
"%s name \"%a\" already defined" msg
(Utils.Cli.format_with_style [ANSITerminal.yellow])
name
in
match Pos.unmark item with
match Marked.unmark item with
| ScopeDecl decl -> (
let name, pos = decl.scope_decl_name in
(* Checks if the name is already used *)
@ -517,7 +505,7 @@ let process_name_item (ctxt : context) (item : Ast.code_item Pos.marked) :
ctxt with
struct_idmap =
Desugared.Ast.IdentMap.add
(Pos.unmark sdecl.struct_decl_name)
(Marked.unmark sdecl.struct_decl_name)
s_uid ctxt.struct_idmap;
})
| EnumDecl edecl -> (
@ -534,15 +522,15 @@ let process_name_item (ctxt : context) (item : Ast.code_item Pos.marked) :
ctxt with
enum_idmap =
Desugared.Ast.IdentMap.add
(Pos.unmark edecl.enum_decl_name)
(Marked.unmark edecl.enum_decl_name)
e_uid ctxt.enum_idmap;
})
| ScopeUse _ -> ctxt
(** Process a code item that is a declaration *)
let process_decl_item (ctxt : context) (item : Ast.code_item Pos.marked) :
let process_decl_item (ctxt : context) (item : Ast.code_item Marked.pos) :
context =
match Pos.unmark item with
match Marked.unmark item with
| ScopeDecl decl -> process_scope_decl ctxt decl
| StructDecl sdecl -> process_struct_decl ctxt sdecl
| EnumDecl edecl -> process_enum_decl ctxt edecl
@ -552,14 +540,14 @@ let process_decl_item (ctxt : context) (item : Ast.code_item Pos.marked) :
let process_code_block
(ctxt : context)
(block : Ast.code_block)
(process_item : context -> Ast.code_item Pos.marked -> context) : context =
(process_item : context -> Ast.code_item Marked.pos -> context) : context =
List.fold_left (fun ctxt decl -> process_item ctxt decl) ctxt block
(** 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 =
(process_item : context -> Ast.code_item Marked.pos -> context) : context =
match s with
| Ast.LawHeading (_, children) ->
List.fold_left
@ -572,7 +560,7 @@ let rec process_law_structure
let get_def_key
(name : Ast.qident)
(state : Ast.ident Pos.marked option)
(state : Ast.ident Marked.pos option)
(scope_uid : Scopelang.Ast.ScopeName.t)
(ctxt : context)
(default_pos : Pos.t) : Desugared.Ast.ScopeDef.t =
@ -587,14 +575,14 @@ let get_def_key
| Some state -> (
try
Some
(Desugared.Ast.IdentMap.find (Pos.unmark state)
(Desugared.Ast.IdentMap.find (Marked.unmark state)
var_sig.var_sig_states_idmap)
with Not_found ->
Errors.raise_multispanned_error
[
None, Pos.get_position state;
None, Marked.get_mark state;
( Some "Variable declaration:",
Pos.get_position (Desugared.Ast.ScopeVar.get_info x_uid) );
Marked.get_mark (Desugared.Ast.ScopeVar.get_info x_uid) );
]
"This identifier is not a state declared for variable %a."
Desugared.Ast.ScopeVar.format_t x_uid)
@ -603,9 +591,9 @@ let get_def_key
then
Errors.raise_multispanned_error
[
None, Pos.get_position x;
None, Marked.get_mark x;
( Some "Variable declaration:",
Pos.get_position (Desugared.Ast.ScopeVar.get_info x_uid) );
Marked.get_mark (Desugared.Ast.ScopeVar.get_info x_uid) );
]
"This definition does not indicate which state has to be \
considered for variable %a."
@ -638,9 +626,9 @@ let process_definition
(fun (s_ctxt : scope_context option) ->
let def_key =
get_def_key
(Pos.unmark d.definition_name)
(Marked.unmark d.definition_name)
d.definition_state s_name ctxt
(Pos.get_position d.definition_expr)
(Marked.get_mark d.definition_expr)
in
match s_ctxt with
| None -> assert false (* should not happen *)
@ -659,7 +647,6 @@ let process_definition
definition for this definition key *)
default_exception_rulename = None;
label_idmap = Desugared.Ast.IdentMap.empty;
label_groups = Desugared.Ast.LabelMap.empty;
}
~some:(fun x -> x)
def_key_ctx
@ -671,7 +658,7 @@ let process_definition
| None -> def_key_ctx
| Some label ->
let new_label_idmap =
Desugared.Ast.IdentMap.update (Pos.unmark label)
Desugared.Ast.IdentMap.update (Marked.unmark label)
(fun existing_label ->
match existing_label with
| Some existing_label -> Some existing_label
@ -679,27 +666,7 @@ let process_definition
Some (Desugared.Ast.LabelName.fresh label))
def_key_ctx.label_idmap
in
let label_id =
Desugared.Ast.IdentMap.find (Pos.unmark label)
new_label_idmap
in
{
def_key_ctx with
label_idmap = new_label_idmap;
label_groups =
Desugared.Ast.LabelMap.update label_id
(fun group ->
match group with
| None ->
Some
(Desugared.Ast.RuleSet.singleton
d.definition_id)
| Some existing_group ->
Some
(Desugared.Ast.RuleSet.add d.definition_id
existing_group))
def_key_ctx.label_groups;
}
{ def_key_ctx with label_idmap = new_label_idmap }
in
(* And second, we update the map of default rulenames for
unlabeled exceptions *)
@ -720,7 +687,7 @@ let process_definition
default_exception_rulename =
Some
(Ambiguous
([Pos.get_position d.definition_name]
([Marked.get_mark d.definition_name]
@
match old with
| Ambiguous old -> old
@ -737,7 +704,7 @@ let process_definition
default_exception_rulename =
Some
(Ambiguous
[Pos.get_position d.definition_name]);
[Marked.get_mark d.definition_name]);
}
(* This is a possible default definition for this
key. We create and store a fresh rulename *)
@ -748,7 +715,7 @@ let process_definition
Some
(Unique
( d.definition_id,
Pos.get_position d.definition_name ));
Marked.get_mark d.definition_name ));
}))
in
Some def_key_ctx)
@ -760,8 +727,8 @@ let process_definition
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
(sitem : Ast.scope_use_item Marked.pos) : context =
match Marked.unmark sitem with
| Rule r -> process_definition ctxt s_name (Ast.rule_to_def r)
| Definition d -> process_definition ctxt s_name d
| _ -> ctxt
@ -770,20 +737,20 @@ 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)
(Marked.unmark suse.Ast.scope_use_name)
ctxt.scope_idmap
with Not_found ->
Errors.raise_spanned_error
(Pos.get_position suse.Ast.scope_use_name)
(Marked.get_mark suse.Ast.scope_use_name)
"\"%a\": this scope has not been declared anywhere, is it a typo?"
(Utils.Cli.format_with_style [ANSITerminal.yellow])
(Pos.unmark suse.Ast.scope_use_name)
(Marked.unmark 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) :
let process_use_item (ctxt : context) (item : Ast.code_item Marked.pos) :
context =
match Pos.unmark item with
match Marked.unmark item with
| ScopeDecl _ | StructDecl _ | EnumDecl _ -> ctxt
| ScopeUse suse -> process_scope_use ctxt suse

33
compiler/surface/name_resolution.mli
View File

@ -27,12 +27,11 @@ type typ = Scopelang.Ast.typ
type unique_rulename =
| Ambiguous of Pos.t list
| Unique of Desugared.Ast.RuleName.t Pos.marked
| Unique of Desugared.Ast.RuleName.t Marked.pos
type scope_def_context = {
default_exception_rulename : unique_rulename option;
label_idmap : Desugared.Ast.LabelName.t Desugared.Ast.IdentMap.t;
label_groups : Desugared.Ast.RuleSet.t Desugared.Ast.LabelMap.t;
}
type scope_context = {
@ -47,14 +46,14 @@ type scope_context = {
}
(** Inside a scope, we distinguish between the variables and the subscopes. *)
type struct_context = typ Pos.marked Scopelang.Ast.StructFieldMap.t
type struct_context = typ Marked.pos Scopelang.Ast.StructFieldMap.t
(** Types of the fields of a struct *)
type enum_context = typ Pos.marked Scopelang.Ast.EnumConstructorMap.t
type enum_context = typ Marked.pos Scopelang.Ast.EnumConstructorMap.t
(** Types of the payloads of the cases of an enum *)
type var_sig = {
var_sig_typ : typ Pos.marked;
var_sig_typ : typ Marked.pos;
var_sig_is_condition : bool;
var_sig_io : Ast.scope_decl_context_io;
var_sig_states_idmap : Desugared.Ast.StateName.t Desugared.Ast.IdentMap.t;
@ -98,11 +97,11 @@ val raise_unsupported_feature : string -> Pos.t -> 'a
(** Temporary function raising an error message saying that a feature is not
supported yet *)
val raise_unknown_identifier : string -> ident Pos.marked -> 'a
val raise_unknown_identifier : string -> ident Marked.pos -> 'a
(** Function to call whenever an identifier used somewhere has not been declared
in the program previously *)
val get_var_typ : context -> Desugared.Ast.ScopeVar.t -> typ Pos.marked
val get_var_typ : context -> Desugared.Ast.ScopeVar.t -> typ Marked.pos
(** Gets the type associated to an uid *)
val is_var_cond : context -> Desugared.Ast.ScopeVar.t -> bool
@ -113,14 +112,14 @@ val get_var_io :
val get_var_uid :
Scopelang.Ast.ScopeName.t ->
context ->
ident Pos.marked ->
ident Marked.pos ->
Desugared.Ast.ScopeVar.t
(** Get the variable uid inside the scope given in argument *)
val get_subscope_uid :
Scopelang.Ast.ScopeName.t ->
context ->
ident Pos.marked ->
ident Marked.pos ->
Scopelang.Ast.SubScopeName.t
(** Get the subscope uid inside the scope given in argument *)
@ -132,26 +131,18 @@ val belongs_to :
context -> Desugared.Ast.ScopeVar.t -> Scopelang.Ast.ScopeName.t -> bool
(** Checks if the var_uid belongs to the scope scope_uid *)
val get_def_typ : context -> Desugared.Ast.ScopeDef.t -> typ Pos.marked
val get_def_typ : context -> Desugared.Ast.ScopeDef.t -> typ Marked.pos
(** Retrieves the type of a scope definition from the context *)
val is_def_cond : context -> Desugared.Ast.ScopeDef.t -> bool
val is_type_cond : Ast.typ Marked.pos -> bool
val label_groups :
context ->
Scopelang.Ast.ScopeName.t ->
Desugared.Ast.ScopeDef.t ->
Desugared.Ast.RuleSet.t Desugared.Ast.LabelMap.t
val is_type_cond : Ast.typ Pos.marked -> bool
val add_def_local_var :
context -> ident Pos.marked -> context * Desugared.Ast.Var.t
val add_def_local_var : context -> ident -> context * Desugared.Ast.Var.t
(** Adds a binding to the context *)
val get_def_key :
Ast.qident ->
Ast.ident Pos.marked option ->
Ast.ident Marked.pos option ->
Scopelang.Ast.ScopeName.t ->
context ->
Pos.t ->

582
compiler/surface/parser.messages
View File

File diff suppressed because it is too large Load Diff

26
compiler/surface/parser.mly
View File

@ -126,9 +126,6 @@ unit_literal:
| MONTH { (Month, Pos.from_lpos $sloc) }
| DAY { (Day, Pos.from_lpos $sloc) }
date_int:
| d = INT_LITERAL { (int_of_string d, Pos.from_lpos $sloc) }
literal:
| l = num_literal u = option(unit_literal) {
(LNumber (l, u), Pos.from_lpos $sloc)
@ -140,7 +137,8 @@ literal:
money_amount_cents = cents;
}, Pos.from_lpos $sloc)
}
| VERTICAL y = date_int MINUS m = date_int MINUS d = date_int VERTICAL {
| VERTICAL d = DATE_LITERAL VERTICAL {
let (y,m,d) = d in
(LDate {
literal_date_year = y;
literal_date_month = m;
@ -176,18 +174,18 @@ compare_op:
aggregate_func:
| CONTENT MAXIMUM t = typ_base INIT init = primitive_expression {
(Aggregate (AggregateArgExtremum (true, Pos.unmark t, init)), Pos.from_lpos $sloc)
(Aggregate (AggregateArgExtremum (true, Marked.unmark t, init)), Pos.from_lpos $sloc)
}
| CONTENT MINIMUM t = typ_base INIT init = primitive_expression {
(Aggregate (AggregateArgExtremum (false, Pos.unmark t, init)), Pos.from_lpos $sloc)
(Aggregate (AggregateArgExtremum (false, Marked.unmark t, init)), Pos.from_lpos $sloc)
}
| MAXIMUM t = typ_base INIT init = primitive_expression {
(Aggregate (AggregateExtremum (true, Pos.unmark t, init)), Pos.from_lpos $sloc)
(Aggregate (AggregateExtremum (true, Marked.unmark t, init)), Pos.from_lpos $sloc)
}
| MINIMUM t = typ_base INIT init = primitive_expression {
(Aggregate (AggregateExtremum (false, Pos.unmark t, init)), Pos.from_lpos $sloc)
(Aggregate (AggregateExtremum (false, Marked.unmark t, init)), Pos.from_lpos $sloc)
}
| SUM t = typ_base { (Aggregate (AggregateSum (Pos.unmark t)), Pos.from_lpos $sloc) }
| SUM t = typ_base { (Aggregate (AggregateSum (Marked.unmark t)), Pos.from_lpos $sloc) }
| CARDINAL { (Aggregate AggregateCount, Pos.from_lpos $sloc) }
| FILTER { (Filter, Pos.from_lpos $sloc ) }
| MAP { (Map, Pos.from_lpos $sloc) }
@ -207,8 +205,8 @@ base_expression:
| e = primitive_expression WITH c = constructor_binding {
(TestMatchCase (e, (c, Pos.from_lpos $sloc)), Pos.from_lpos $sloc)
}
| e1 = primitive_expression IN e2 = base_expression {
(MemCollection (e1, e2), Pos.from_lpos $sloc)
| e1 = primitive_expression CONTAINS e2 = base_expression {
(MemCollection (e2, e1), Pos.from_lpos $sloc)
}
unop:
@ -379,7 +377,7 @@ rule:
state = option(state)
consequence = rule_consequence {
let (name, param_applied) = name_and_param in
let cons : bool Pos.marked = consequence in
let cons : bool Marked.pos = consequence in
let rule_exception = match except with | None -> NotAnException | Some x -> x in
({
rule_label = label;
@ -388,7 +386,7 @@ rule:
rule_condition = cond;
rule_name = name;
rule_id = Desugared.Ast.RuleName.fresh
(String.concat "." (List.map (fun i -> Pos.unmark i) (Pos.unmark name)),
(String.concat "." (List.map (fun i -> Marked.unmark i) (Marked.unmark name)),
Pos.from_lpos $sloc);
rule_consequence = cons;
rule_state = state;
@ -425,7 +423,7 @@ definition:
definition_condition = cond;
definition_id =
Desugared.Ast.RuleName.fresh
(String.concat "." (List.map (fun i -> Pos.unmark i) (Pos.unmark name)),
(String.concat "." (List.map (fun i -> Marked.unmark i) (Marked.unmark name)),
Pos.from_lpos $sloc);
definition_expr = e;
definition_state = state;

4
compiler/surface/parser_driver.ml
View File

@ -305,7 +305,9 @@ and expand_includes
match command with
| Ast.LawInclude (Ast.CatalaFile sub_source) ->
let source_dir = Filename.dirname source_file in
let sub_source = Filename.concat source_dir (Pos.unmark sub_source) in
let sub_source =
Filename.concat source_dir (Marked.unmark sub_source)
in
let includ_program = parse_source_file (FileName sub_source) language in
{
Ast.program_source_files =

3
compiler/surface/tokens.mly
View File

@ -32,12 +32,13 @@
%token<string> CONSTRUCTOR IDENT
%token<string> END_CODE
%token<string> INT_LITERAL
%token<int * int * int> DATE_LITERAL
%token TRUE FALSE
%token<string * string> DECIMAL_LITERAL
%token<string * string> MONEY_AMOUNT
%token BEGIN_CODE TEXT
%token COLON ALT DATA VERTICAL
%token OF INTEGER COLLECTION
%token OF INTEGER COLLECTION CONTAINS
%token RULE CONDITION DEFINED_AS
%token LESSER GREATER LESSER_EQUAL GREATER_EQUAL
%token LESSER_DEC GREATER_DEC LESSER_EQUAL_DEC GREATER_EQUAL_DEC

81
compiler/utils/cli.ml
View File

@ -94,18 +94,35 @@ let file =
let debug =
Arg.(value & flag & info ["debug"; "d"] ~doc:"Prints debug information.")
type when_enum = Auto | Always | Never
let when_opt = Arg.enum ["auto", Auto; "always", Always; "never", Never]
let color =
Arg.(
value
& opt ~vopt:Always when_opt Auto
& info ["color"]
~doc:
"Allow output of colored and styled text. If set to $(i,auto), \
enabled when the standard output is to a terminal.")
let unstyled =
Arg.(
value & flag
value
& flag
& info ["unstyled"; "u"]
~doc:"Removes styling (colors, etc.) from terminal output.")
~doc:
"Removes styling (colors, etc.) from terminal output. Equivalent to \
$(b,--color=never)")
let optimize =
Arg.(value & flag & info ["optimize"; "O"] ~doc:"Run compiler optimizations.")
let trace_opt =
Arg.(
value & flag
value
& flag
& info ["trace"; "t"]
~doc:
"Displays a trace of the interpreter's computation or generates \
@ -113,25 +130,29 @@ let trace_opt =
let avoid_exceptions =
Arg.(
value & flag
value
& flag
& info ["avoid_exceptions"]
~doc:"Compiles the default calculus without exceptions")
let closure_conversion =
Arg.(
value & flag
value
& flag
& info ["closure_conversion"]
~doc:"Performs closure conversion on the lambda calculus")
let wrap_weaved_output =
Arg.(
value & flag
value
& flag
& info ["wrap"; "w"]
~doc:"Wraps literate programming output with a minimal preamble.")
let print_only_law =
Arg.(
value & flag
value
& flag
& info ["print_only_law"]
~doc:
"In literate programming output, skip all code and metadata sections \
@ -174,7 +195,8 @@ let max_prec_digits_opt =
let disable_counterexamples_opt =
Arg.(
value & flag
value
& flag
& info
["disable_counterexamples"]
~doc:
@ -200,7 +222,7 @@ let output =
type options = {
debug : bool;
unstyled : bool;
color : when_enum;
wrap_weaved_output : bool;
avoid_exceptions : bool;
backend : string;
@ -219,6 +241,7 @@ type options = {
let options =
let make
debug
color
unstyled
wrap_weaved_output
avoid_exceptions
@ -235,7 +258,7 @@ let options =
print_only_law : options =
{
debug;
unstyled;
color = (if unstyled then Never else color);
wrap_weaved_output;
avoid_exceptions;
backend;
@ -252,16 +275,33 @@ let options =
}
in
Term.(
const make $ debug $ unstyled $ wrap_weaved_output $ avoid_exceptions
$ closure_conversion $ backend $ plugins_dirs $ language
$ max_prec_digits_opt $ trace_opt $ disable_counterexamples_opt $ optimize
$ ex_scope $ output $ print_only_law)
const make
$ debug
$ color
$ unstyled
$ wrap_weaved_output
$ avoid_exceptions
$ closure_conversion
$ backend
$ plugins_dirs
$ language
$ max_prec_digits_opt
$ trace_opt
$ disable_counterexamples_opt
$ optimize
$ ex_scope
$ output
$ print_only_law)
let catala_t f = Term.(const f $ file $ options)
let set_option_globals options : unit =
debug_flag := options.debug;
style_flag := not options.unstyled;
(style_flag :=
match options.color with
| Always -> true
| Never -> false
| Auto -> Unix.isatty Unix.stdout);
trace_flag := options.trace;
optimize_flag := options.optimize;
disable_counterexamples := options.disable_counterexamples;
@ -361,6 +401,13 @@ let format_with_style (styles : ANSITerminal.style list) fmt (str : string) =
(ANSITerminal.sprintf styles "%s" str)
else Format.pp_print_string fmt str
let call_unstyled f =
let prev = !style_flag in
style_flag := false;
let res = f () in
style_flag := prev;
res
let time_marker () =
let new_time = Unix.gettimeofday () in
let old_time = !time in
@ -405,7 +452,9 @@ let concat_with_line_depending_prefix_and_suffix
let out, _ =
List.fold_left
(fun (acc, i) s ->
( (acc ^ prefix i ^ s
( (acc
^ prefix i
^ s
^ if i = List.length ss - 1 then "" else suffix i),
i + 1 ))
((prefix 0 ^ hd ^ if 0 = List.length ss - 1 then "" else suffix 0), 1)

9
compiler/utils/cli.mli
View File

@ -81,9 +81,12 @@ val max_prec_digits_opt : int option Cmdliner.Term.t
val ex_scope : string option Cmdliner.Term.t
val output : string option Cmdliner.Term.t
(** The usual auto/always/never option argument *)
type when_enum = Auto | Always | Never
type options = {
debug : bool;
unstyled : bool;
color : when_enum;
wrap_weaved_output : bool;
avoid_exceptions : bool;
backend : string;
@ -118,6 +121,10 @@ val with_style : ANSITerminal.style list -> ('a, unit, string) format -> 'a
val format_with_style :
ANSITerminal.style list -> Format.formatter -> string -> unit
val call_unstyled : (unit -> 'a) -> 'a
(** [call_unstyled f] calls the function [f] with the [style_flag] set to false
during the execution. *)
val debug_marker : unit -> string
val error_marker : unit -> string
val warning_marker : unit -> string

2
compiler/utils/dune
View File

@ -1,7 +1,7 @@
(library
(name utils)
(public_name catala.utils)
(libraries cmdliner ANSITerminal re))
(libraries cmdliner ubase ANSITerminal re))
(documentation
(package catala)

15
compiler/utils/file.ml
View File

@ -45,3 +45,18 @@ let with_formatter_of_opt_file filename_opt f =
match filename_opt with
| None -> finally (fun () -> flush stdout) (fun () -> f Format.std_formatter)
| Some filename -> with_formatter_of_file filename f
let get_out_channel ~source_file ~output_file ?ext () =
match output_file, ext with
| Some "-", _ | None, None -> None, fun f -> f stdout
| Some f, _ -> Some f, with_out_channel f
| None, Some ext ->
let src =
match source_file with Pos.FileName f -> f | Pos.Contents _ -> "a"
in
let f = Filename.remove_extension src ^ ext in
Some f, with_out_channel f
let get_formatter_of_out_channel ~source_file ~output_file ?ext () =
let f, with_ = get_out_channel ~source_file ~output_file ?ext () in
f, fun fmt -> with_ (fun oc -> with_formatter_of_out_channel oc fmt)

20
compiler/utils/file.mli
View File

@ -40,3 +40,23 @@ val with_formatter_of_opt_file : string option -> (Format.formatter -> 'a) -> 'a
(** [with_formatter_of_opt_file filename_opt f] manages the formatter created
from the file [filename_opt] if there is some (see
{!with_formatter_of_file}), otherwise, uses the [Format.std_formatter]. *)
val get_out_channel :
source_file:Pos.input_file ->
output_file:string option ->
?ext:string ->
unit ->
string option * ((out_channel -> 'a) -> 'a)
(** [get_output ~source_file ~output_file ?ext ()] returns the infered filename
and its corresponding [with_out_channel] function. If the [output_file] is
equal to [Some "-"] returns a wrapper around [stdout]. *)
val get_formatter_of_out_channel :
source_file:Pos.input_file ->
output_file:string option ->
?ext:string ->
unit ->
string option * ((Format.formatter -> 'a) -> 'a)
(** [get_output_format ~source_file ~output_file ?ext ()] returns the infered
filename and its corresponding [with_formatter_of_out_channel] function. If
the [output_file] is equal to [Some "-"] returns a wrapper around [stdout]. *)

78
compiler/utils/marked.ml Normal file
View File

@ -0,0 +1,78 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria,
contributors: Denis Merigoux <denis.merigoux@inria.fr>, Louis Gesbert
<louis.gesbert@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 ('a, 'm) t = 'a * 'm
type 'a pos = ('a, Pos.t) t
let mark m e : ('a, 'm) t = e, m
let unmark ((x, _) : ('a, 'm) t) : 'a = x
let get_mark ((_, x) : ('a, 'm) t) : 'm = x
let map_under_mark (f : 'a -> 'b) ((x, y) : ('a, 'm) t) : ('b, 'c) t = f x, y
let same_mark_as (x : 'a) ((_, y) : ('b, 'm) t) : ('a, 'm) t = x, y
let unmark_option (x : ('a, 'm) t option) : 'a option =
match x with Some x -> Some (unmark x) | None -> None
let compare (cmp : 'a -> 'a -> int) ((x, _) : ('a, 'm) t) ((y, _) : ('a, 'm) t)
: int =
cmp x y
class ['self] marked_map =
object (_self : 'self)
constraint
'self = < visit_marked :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) t -> ('a, 'm) t
; .. >
method visit_marked
: 'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) t -> ('a, 'm) t =
fun f env x -> same_mark_as (f env (unmark x)) x
end
class ['self] marked_iter =
object (_self : 'self)
constraint
'self = < visit_marked :
'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) t -> unit
; .. >
method visit_marked : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) t -> unit
=
fun f env x -> f env (unmark x)
end
class ['self] pos_map =
object (_self : 'self)
constraint
'self = < visit_pos :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) t -> ('a, 'm) t
; .. >
method visit_pos
: 'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) t -> ('a, 'm) t =
fun f env x -> same_mark_as (f env (unmark x)) x
end
class ['self] pos_iter =
object (_self : 'self)
constraint
'self = < visit_pos : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) t -> unit
; .. >
method visit_pos : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) t -> unit =
fun f env x -> f env (unmark x)
end

78
compiler/utils/marked.mli Normal file
View File

@ -0,0 +1,78 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria,
contributors: Denis Merigoux <denis.merigoux@inria.fr>, Louis Gesbert
<louis.gesbert@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. *)
(** AST node annotations (used for position, type, etc.) *)
type ('a, 'm) t = 'a * 'm
(** Everything related to the source code should keep at least its position
stored, to improve error messages *)
type 'a pos = ('a, Pos.t) t
(** The type of marks containing only position information *)
val mark : 'm -> 'a -> ('a, 'm) t
val unmark : ('a, 'm) t -> 'a
val get_mark : ('a, 'm) t -> 'm
val map_under_mark : ('a -> 'b) -> ('a, 'm) t -> ('b, 'm) t
val same_mark_as : 'a -> ('b, 'm) t -> ('a, 'm) t
val unmark_option : ('a, 'm) t option -> 'a option
val compare : ('a -> 'a -> int) -> ('a, 'm) t -> ('a, 'm) t -> int
(** Compares two marked values {b ignoring positions} *)
(** Visitors *)
class ['self] marked_map :
object ('self)
constraint
'self = < visit_marked :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) t -> ('a, 'm) t
; .. >
method visit_marked :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) t -> ('a, 'm) t
end
class ['self] marked_iter :
object ('self)
constraint
'self = < visit_marked :
'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) t -> unit
; .. >
method visit_marked : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) t -> unit
end
class ['self] pos_map :
object ('self)
constraint
'self = < visit_pos :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) t -> ('a, 'm) t
; .. >
method visit_pos :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) t -> ('a, 'm) t
end
class ['self] pos_iter :
object ('self)
constraint
'self = < visit_pos : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) t -> unit
; .. >
method visit_pos : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) t -> unit
end

41
compiler/utils/pos.ml
View File

@ -203,8 +203,6 @@ let retrieve_loc_text (pos : t) : string =
else Cli.with_style blue_style "%*s+-+ " (spaces + (2 * i) - 1) ""))
with Sys_error _ -> "Location:" ^ to_string pos
type 'a marked = 'a * t
let no_pos : t =
let zero_pos =
{
@ -215,42 +213,3 @@ let no_pos : t =
}
in
{ code_pos = zero_pos, zero_pos; law_pos = [] }
let mark pos e : 'a marked = e, 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 compare_marked
(cmp : 'a -> 'a -> int)
((x, _) : 'a marked)
((y, _) : 'a marked) : int =
cmp x y
let unmark_option (x : 'a marked option) : 'a option =
match x with Some x -> Some (unmark x) | None -> None
class ['self] marked_map =
object (_self : 'self)
constraint
'self = < visit_marked :
'a. ('env -> 'a -> 'a) -> 'env -> 'a marked -> 'a marked
; .. >
method visit_marked
: 'a. ('env -> 'a -> 'a) -> 'env -> 'a marked -> 'a marked =
fun f env x -> same_pos_as (f env (unmark x)) x
end
class ['self] marked_iter =
object (_self : 'self)
constraint
'self = < visit_marked :
'a. ('env -> 'a -> unit) -> 'env -> 'a marked -> unit
; .. >
method visit_marked : 'a. ('env -> 'a -> unit) -> 'env -> 'a marked -> unit
=
fun f env x -> f env (unmark x)
end

41
compiler/utils/pos.mli
View File

@ -20,8 +20,6 @@ type t
(** A position in the source code is a file, as well as begin and end location
of the form col:line *)
(** Custom visitor for the [Pos.marked] type *)
(**{2 Constructor and getters}*)
val from_lpos : Lexing.position * Lexing.position -> t
@ -52,44 +50,5 @@ val retrieve_loc_text : t -> string
(** Open the file corresponding to the position and retrieves the text concerned
by the position *)
(**{2 AST markings}*)
type 'a marked = 'a * t
(** Everything related to the source code should keep its position stored, to
improve error messages *)
val no_pos : t
(** Placeholder position *)
val mark : t -> 'a -> 'a marked
val unmark : 'a marked -> 'a
val get_position : 'a marked -> t
val map_under_mark : ('a -> 'b) -> 'a marked -> 'b marked
val same_pos_as : 'a -> 'b marked -> 'a marked
val unmark_option : 'a marked option -> 'a option
val compare_marked : ('a -> 'a -> int) -> 'a marked -> 'a marked -> int
(** Compares two marked values {b ignoring positions} *)
(** Visitors *)
class ['self] marked_map :
object ('self)
constraint
'self = < visit_marked :
'a. ('env -> 'a -> 'a) -> 'env -> 'a marked -> 'a marked
; .. >
method visit_marked :
'a. ('env -> 'a -> 'a) -> 'env -> 'a marked -> 'a marked
end
class ['self] marked_iter :
object ('self)
constraint
'self = < visit_marked :
'a. ('env -> 'a -> unit) -> 'env -> 'a marked -> unit
; .. >
method visit_marked : 'a. ('env -> 'a -> unit) -> 'env -> 'a marked -> unit
end

52
compiler/utils/string_common.ml Normal file
View File

@ -0,0 +1,52 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
Denis Merigoux <denis.merigoux@inria.fr>, Emile Rolley <emile.rolley@tuta.io>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
let to_ascii : string -> string = Ubase.from_utf8
let is_uppercase_ascii (c : char) : bool =
let c = Char.code c in
(* 'A' <= c && c <= 'Z' *)
0x41 <= c && c <= 0x5b
let begins_with_uppercase (s : string) : bool =
if "" = s then false else is_uppercase_ascii (to_ascii s).[0]
let to_snake_case (s : string) : string =
let out = ref "" in
to_ascii s
|> String.iteri (fun i c ->
out :=
!out
^ (if is_uppercase_ascii c && 0 <> i then "_" else "")
^ String.lowercase_ascii (String.make 1 c));
!out
let to_camel_case (s : string) : string =
let last_was_underscore = ref false in
let out = ref "" in
to_ascii s
|> String.iteri (fun i c ->
let is_underscore = c = '_' in
let c_string = String.make 1 c in
out :=
!out
^
if is_underscore then ""
else if !last_was_underscore || 0 = i then
String.uppercase_ascii c_string
else c_string;
last_was_underscore := is_underscore);
!out

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