mirror of
https://github.com/CatalaLang/catala.git
synced 2024-11-08 07:51:43 +03:00
Added machinery for Python backend
This commit is contained in:
Denis Merigoux
parent
867126f8e4
commit
9ab32efcce
@ -68,6 +68,7 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool)
|
||||
else if backend = "ocaml" then Cli.OCaml
|
||||
else if backend = "dcalc" then Cli.Dcalc
|
||||
else if backend = "scopelang" then Cli.Scopelang
|
||||
else if backend = "python" then Cli.Python
|
||||
else
|
||||
Errors.raise_error
|
||||
(Printf.sprintf "The selected backend (%s) is not supported by Catala" backend)
|
||||
@ -240,7 +241,7 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool)
|
||||
result))
|
||||
results;
|
||||
0
|
||||
| Cli.OCaml ->
|
||||
| Cli.OCaml | Cli.Python ->
|
||||
Cli.debug_print "Compiling program into lambda calculus...";
|
||||
let prgm = Lcalc.Compile_with_exceptions.translate_program prgm in
|
||||
let prgm =
|
||||
@ -254,7 +255,7 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool)
|
||||
match source_file with
|
||||
| FileName f -> f
|
||||
| Contents _ ->
|
||||
Errors.raise_error "The OCaml backend does not work if the input is not a file"
|
||||
Errors.raise_error "This backend does not work if the input is not a file"
|
||||
in
|
||||
let output_file =
|
||||
match output_file with
|
||||
@ -264,8 +265,15 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool)
|
||||
Cli.debug_print (Printf.sprintf "Writing to %s..." output_file);
|
||||
let oc = open_out output_file in
|
||||
let fmt = Format.formatter_of_out_channel oc in
|
||||
Cli.debug_print "Compiling program into OCaml...";
|
||||
Lcalc.To_ocaml.format_program fmt prgm type_ordering;
|
||||
|
||||
(match backend with
|
||||
| Cli.OCaml ->
|
||||
Cli.debug_print "Compiling program into OCaml...";
|
||||
Lcalc.To_ocaml.format_program fmt prgm type_ordering
|
||||
| Cli.Python ->
|
||||
Cli.debug_print "Compiling program into Python...";
|
||||
Lcalc.To_python.format_program fmt prgm type_ordering
|
||||
| _ -> assert false (* should not happen *));
|
||||
close_out oc;
|
||||
0
|
||||
| _ -> assert false
|
||||
|
||||
54
compiler/lcalc/backends.ml
Normal file
54
compiler/lcalc/backends.ml
Normal file
@ -0,0 +1,54 @@
|
||||
(* This file is part of the Catala compiler, a specification language for tax and social benefits
|
||||
computation rules. Copyright (C) 2021 Inria, contributor: Denis Merigoux
|
||||
<denis.merigoux@inria.fr>
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
|
||||
in compliance with the License. You may obtain a copy of the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software distributed under the License
|
||||
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
|
||||
or implied. See the License for the specific language governing permissions and limitations under
|
||||
the License. *)
|
||||
|
||||
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
|
||||
20
compiler/lcalc/backends.mli
Normal file
20
compiler/lcalc/backends.mli
Normal file
@ -0,0 +1,20 @@
|
||||
(* This file is part of the Catala compiler, a specification language for tax and social benefits
|
||||
computation rules. Copyright (C) 2021 Inria, contributor: Denis Merigoux
|
||||
<denis.merigoux@inria.fr>
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
|
||||
in compliance with the License. You may obtain a copy of the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software distributed under the License
|
||||
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
|
||||
or implied. See the License for the specific language governing permissions and limitations under
|
||||
the License. *)
|
||||
|
||||
val to_ascii : string -> string
|
||||
(** Removes all non-ASCII diacritics from a string by converting them to their base letter in the
|
||||
Latin alphabet *)
|
||||
|
||||
val to_lowercase : string -> string
|
||||
(** Converts CamlCase into snake_case *)
|
||||
@ -22,11 +22,12 @@ Related modules:
|
||||
default calculus using catchable exceptions. This compilation scheme has been
|
||||
certified.
|
||||
|
||||
{1 OCaml backend}
|
||||
{1 Backends}
|
||||
|
||||
Related modules:
|
||||
|
||||
{!modules: Lcalc.To_ocaml}
|
||||
{!modules: Lcalc.To_ocaml Lcalc.To_python Lcalc.Backends}
|
||||
|
||||
The OCaml backend of the lambda calculus is merely a syntactic formatting,
|
||||
since the core of the OCaml value language is effectively a lambda calculus.
|
||||
since the core of the OCaml value language is effectively a lambda calculus.
|
||||
|
||||
|
||||
@ -14,6 +14,7 @@
|
||||
|
||||
open Utils
|
||||
open Ast
|
||||
open Backends
|
||||
module D = Dcalc.Ast
|
||||
|
||||
let format_lit (fmt : Format.formatter) (l : lit Pos.marked) : unit =
|
||||
@ -94,47 +95,6 @@ let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Pos.marked) : unit
|
||||
| GetMonth -> Format.fprintf fmt "%s" "month_number_of_date"
|
||||
| GetYear -> Format.fprintf fmt "%s" "year_of_date"
|
||||
|
||||
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 avoid_keywords (s : string) : string =
|
||||
if
|
||||
match s with
|
||||
|
||||
434
compiler/lcalc/to_python.ml
Normal file
434
compiler/lcalc/to_python.ml
Normal file
@ -0,0 +1,434 @@
|
||||
(* This file is part of the Catala compiler, a specification language for tax and social benefits
|
||||
computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux
|
||||
<denis.merigoux@inria.fr>
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
|
||||
in compliance with the License. You may obtain a copy of the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software distributed under the License
|
||||
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
|
||||
or implied. See the License for the specific language governing permissions and limitations under
|
||||
the License. *)
|
||||
|
||||
open Utils
|
||||
open Ast
|
||||
open Backends
|
||||
module D = Dcalc.Ast
|
||||
|
||||
let format_lit (fmt : Format.formatter) (l : lit Pos.marked) : unit =
|
||||
match Pos.unmark l with
|
||||
| LBool b -> Dcalc.Print.format_lit fmt (Pos.same_pos_as (Dcalc.Ast.LBool b) l)
|
||||
| LInt i -> Format.fprintf fmt "integer_of_string@ \"%s\"" (Runtime.integer_to_string i)
|
||||
| LUnit -> Dcalc.Print.format_lit fmt (Pos.same_pos_as Dcalc.Ast.LUnit l)
|
||||
| LRat i ->
|
||||
Format.fprintf fmt "decimal_of_string \"%a\"" Dcalc.Print.format_lit
|
||||
(Pos.same_pos_as (Dcalc.Ast.LRat i) l)
|
||||
| LMoney e ->
|
||||
Format.fprintf fmt "money_of_cents_string@ \"%s\""
|
||||
(Runtime.integer_to_string (Runtime.money_to_cents e))
|
||||
| LDate d ->
|
||||
Format.fprintf fmt "date_of_numbers %d %d %d"
|
||||
(Runtime.integer_to_int (Runtime.year_of_date d))
|
||||
(Runtime.integer_to_int (Runtime.month_number_of_date d))
|
||||
(Runtime.integer_to_int (Runtime.day_of_month_of_date d))
|
||||
| LDuration d ->
|
||||
let years, months, days = Runtime.duration_to_years_months_days d in
|
||||
Format.fprintf fmt "duration_of_numbers %d %d %d" years months days
|
||||
|
||||
let format_op_kind (fmt : Format.formatter) (k : Dcalc.Ast.op_kind) =
|
||||
Format.fprintf fmt "%s"
|
||||
(match k with KInt -> "!" | KRat -> "&" | KMoney -> "$" | KDate -> "@" | KDuration -> "^")
|
||||
|
||||
let format_log_entry (fmt : Format.formatter) (entry : Dcalc.Ast.log_entry) : unit =
|
||||
match entry with
|
||||
| VarDef _ -> Format.fprintf fmt ":="
|
||||
| BeginCall -> Format.fprintf fmt "→ "
|
||||
| EndCall -> Format.fprintf fmt "%s" "← "
|
||||
| PosRecordIfTrueBool -> Format.fprintf fmt "☛ "
|
||||
|
||||
let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Pos.marked) : unit =
|
||||
match Pos.unmark op with
|
||||
| Add k -> Format.fprintf fmt "+%a" format_op_kind k
|
||||
| Sub k -> Format.fprintf fmt "-%a" format_op_kind k
|
||||
| Mult k -> Format.fprintf fmt "*%a" format_op_kind k
|
||||
| Div k -> Format.fprintf fmt "/%a" format_op_kind k
|
||||
| And -> Format.fprintf fmt "%s" "&&"
|
||||
| Or -> Format.fprintf fmt "%s" "||"
|
||||
| Eq -> Format.fprintf fmt "%s" "="
|
||||
| Neq | Xor -> Format.fprintf fmt "%s" "<>"
|
||||
| Lt k -> Format.fprintf fmt "%s%a" "<" format_op_kind k
|
||||
| Lte k -> Format.fprintf fmt "%s%a" "<=" format_op_kind k
|
||||
| Gt k -> Format.fprintf fmt "%s%a" ">" format_op_kind k
|
||||
| Gte k -> Format.fprintf fmt "%s%a" ">=" format_op_kind k
|
||||
| Map -> Format.fprintf fmt "Array.map"
|
||||
| Filter -> Format.fprintf fmt "array_filter"
|
||||
|
||||
let format_ternop (fmt : Format.formatter) (op : Dcalc.Ast.ternop Pos.marked) : unit =
|
||||
match Pos.unmark op with Fold -> Format.fprintf fmt "Array.fold_left"
|
||||
|
||||
let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list) : unit =
|
||||
Format.fprintf fmt "@[<hov 2>[%a]@]"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
|
||||
(fun fmt info -> Format.fprintf fmt "\"%a\"" Utils.Uid.MarkedString.format_info info))
|
||||
uids
|
||||
|
||||
let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
|
||||
Format.fprintf fmt "@[<hov 2>[%a]@]"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
|
||||
(fun fmt info -> Format.fprintf fmt "\"%s\"" info))
|
||||
uids
|
||||
|
||||
let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Pos.marked) : unit =
|
||||
match Pos.unmark op with
|
||||
| Minus k -> Format.fprintf fmt "~-%a" format_op_kind k
|
||||
| Not -> Format.fprintf fmt "%s" "not"
|
||||
| Log (entry, infos) ->
|
||||
Format.fprintf fmt "@[<hov 2>log_entry@ \"%a|%a\"@]" format_log_entry entry format_uid_list
|
||||
infos
|
||||
| Length -> Format.fprintf fmt "%s" "array_length"
|
||||
| IntToRat -> Format.fprintf fmt "%s" "decimal_of_integer"
|
||||
| GetDay -> Format.fprintf fmt "%s" "day_of_month_of_date"
|
||||
| GetMonth -> Format.fprintf fmt "%s" "month_number_of_date"
|
||||
| GetYear -> Format.fprintf fmt "%s" "year_of_date"
|
||||
|
||||
let avoid_keywords (s : string) : string =
|
||||
if
|
||||
match s with
|
||||
(* list taken from http://caml.inria.fr/pub/docs/manual-ocaml/lex.html#sss:keywords *)
|
||||
| "and" | "as" | "assert" | "asr" | "begin" | "class" | "constraint" | "do" | "done" | "downto"
|
||||
| "else" | "end" | "exception" | "external" | "false" | "for" | "fun" | "function" | "functor"
|
||||
| "if" | "in" | "include" | "inherit" | "initializer" | "land" | "lazy" | "let" | "lor" | "lsl"
|
||||
| "lsr" | "lxor" | "match" | "method" | "mod" | "module" | "mutable" | "new" | "nonrec"
|
||||
| "object" | "of" | "open" | "or" | "private" | "rec" | "sig" | "struct" | "then" | "to"
|
||||
| "true" | "try" | "type" | "val" | "virtual" | "when" | "while" | "with" ->
|
||||
true
|
||||
| _ -> false
|
||||
then s ^ "_"
|
||||
else s
|
||||
|
||||
let format_struct_name (fmt : Format.formatter) (v : Dcalc.Ast.StructName.t) : unit =
|
||||
Format.fprintf fmt "%s"
|
||||
(avoid_keywords
|
||||
(to_lowercase (to_ascii (Format.asprintf "%a" Dcalc.Ast.StructName.format_t v))))
|
||||
|
||||
let format_struct_field_name (fmt : Format.formatter) (v : Dcalc.Ast.StructFieldName.t) : unit =
|
||||
Format.fprintf fmt "%s"
|
||||
(avoid_keywords (to_ascii (Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v)))
|
||||
|
||||
let format_enum_name (fmt : Format.formatter) (v : Dcalc.Ast.EnumName.t) : unit =
|
||||
Format.fprintf fmt "%s"
|
||||
(avoid_keywords (to_lowercase (to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumName.format_t v))))
|
||||
|
||||
let format_enum_cons_name (fmt : Format.formatter) (v : Dcalc.Ast.EnumConstructor.t) : unit =
|
||||
Format.fprintf fmt "%s"
|
||||
(avoid_keywords (to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumConstructor.format_t v)))
|
||||
|
||||
let rec typ_embedding_name (fmt : Format.formatter) (ty : D.typ Pos.marked) : unit =
|
||||
match Pos.unmark ty with
|
||||
| D.TLit D.TUnit -> Format.fprintf fmt "embed_unit"
|
||||
| D.TLit D.TBool -> Format.fprintf fmt "embed_bool"
|
||||
| D.TLit D.TInt -> Format.fprintf fmt "embed_integer"
|
||||
| D.TLit D.TRat -> Format.fprintf fmt "embed_decimal"
|
||||
| D.TLit D.TMoney -> Format.fprintf fmt "embed_money"
|
||||
| D.TLit D.TDate -> Format.fprintf fmt "embed_date"
|
||||
| D.TLit D.TDuration -> Format.fprintf fmt "embed_duration"
|
||||
| D.TTuple (_, Some s_name) -> Format.fprintf fmt "embed_%a" format_struct_name s_name
|
||||
| D.TEnum (_, e_name) -> Format.fprintf fmt "embed_%a" format_enum_name e_name
|
||||
| D.TArray ty -> Format.fprintf fmt "embed_array (%a)" typ_embedding_name ty
|
||||
| _ -> Format.fprintf fmt "unembeddable"
|
||||
|
||||
let typ_needs_parens (e : Dcalc.Ast.typ Pos.marked) : bool =
|
||||
match Pos.unmark e with TArrow _ | TArray _ -> true | _ -> false
|
||||
|
||||
let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Pos.marked) : unit =
|
||||
let format_typ = format_typ in
|
||||
let format_typ_with_parens (fmt : Format.formatter) (t : Dcalc.Ast.typ Pos.marked) =
|
||||
if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t
|
||||
else Format.fprintf fmt "%a" format_typ t
|
||||
in
|
||||
match Pos.unmark typ with
|
||||
| TLit l -> Format.fprintf fmt "%a" Dcalc.Print.format_tlit l
|
||||
| TTuple (ts, None) ->
|
||||
Format.fprintf fmt "@[<hov 2>(%a)@]"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ *@ ")
|
||||
(fun fmt t -> Format.fprintf fmt "%a" format_typ_with_parens t))
|
||||
ts
|
||||
| TTuple (_, Some s) -> Format.fprintf fmt "%a" format_struct_name s
|
||||
| TEnum (_, e) -> Format.fprintf fmt "%a" format_enum_name e
|
||||
| TArrow (t1, t2) ->
|
||||
Format.fprintf fmt "@[<hov 2>%a ->@ %a@]" format_typ_with_parens t1 format_typ_with_parens t2
|
||||
| TArray t1 -> Format.fprintf fmt "@[%a@ array@]" format_typ_with_parens t1
|
||||
| TAny -> Format.fprintf fmt "_"
|
||||
|
||||
let format_var (fmt : Format.formatter) (v : Var.t) : unit =
|
||||
let lowercase_name = to_lowercase (to_ascii (Bindlib.name_of v)) in
|
||||
let lowercase_name =
|
||||
Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.") ~subst:(fun _ -> "_dot_") lowercase_name
|
||||
in
|
||||
let lowercase_name = avoid_keywords (to_ascii lowercase_name) in
|
||||
if lowercase_name = "handle_default" || Dcalc.Print.begins_with_uppercase (Bindlib.name_of v) then
|
||||
Format.fprintf fmt "%s" lowercase_name
|
||||
else if lowercase_name = "_" then Format.fprintf fmt "%s" lowercase_name
|
||||
else Format.fprintf fmt "%s_" lowercase_name
|
||||
|
||||
let needs_parens (e : expr Pos.marked) : bool =
|
||||
match Pos.unmark e with
|
||||
| EApp ((EAbs (_, _), _), _) | ELit (LBool _ | LUnit) | EVar _ | ETuple _ | EOp _ -> false
|
||||
| _ -> true
|
||||
|
||||
let format_exception (fmt : Format.formatter) (exc : except Pos.marked) : unit =
|
||||
match Pos.unmark exc with
|
||||
| ConflictError -> Format.fprintf fmt "ConflictError"
|
||||
| EmptyError -> Format.fprintf fmt "EmptyError"
|
||||
| Crash -> Format.fprintf fmt "Crash"
|
||||
| NoValueProvided ->
|
||||
let pos = Pos.get_position exc in
|
||||
Format.fprintf fmt
|
||||
"(NoValueProvided@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ start_column=%d;@ \
|
||||
end_line=%d; end_column=%d;@ law_headings=%a}@])"
|
||||
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
|
||||
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos)
|
||||
|
||||
let rec format_expr (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : expr Pos.marked) : unit
|
||||
=
|
||||
let format_expr = format_expr ctx in
|
||||
let format_with_parens (fmt : Format.formatter) (e : expr Pos.marked) =
|
||||
if needs_parens e then Format.fprintf fmt "(%a)" format_expr e
|
||||
else Format.fprintf fmt "%a" format_expr e
|
||||
in
|
||||
match Pos.unmark e with
|
||||
| EVar v -> Format.fprintf fmt "%a" format_var (Pos.unmark v)
|
||||
| ETuple (es, None) ->
|
||||
Format.fprintf fmt "@[<hov 2>(%a)@]"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||
(fun fmt e -> Format.fprintf fmt "%a" format_with_parens e))
|
||||
es
|
||||
| ETuple (es, Some s) ->
|
||||
if List.length es = 0 then Format.fprintf fmt "()"
|
||||
else
|
||||
Format.fprintf fmt "{@[<hov 2>%a@]}"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
|
||||
(fun fmt (e, struct_field) ->
|
||||
Format.fprintf fmt "@[<hov 2>%a =@ %a@]" format_struct_field_name struct_field
|
||||
format_with_parens e))
|
||||
(List.combine es (List.map fst (Dcalc.Ast.StructMap.find s ctx.ctx_structs)))
|
||||
| EArray es ->
|
||||
Format.fprintf fmt "@[<hov 2>[|%a|]@]"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
|
||||
(fun fmt e -> Format.fprintf fmt "%a" format_with_parens e))
|
||||
es
|
||||
| ETupleAccess (e1, n, s, ts) -> (
|
||||
match s with
|
||||
| None ->
|
||||
Format.fprintf fmt "let@ %a@ = %a@ in@ x"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||
(fun fmt i -> Format.fprintf fmt "%s" (if i = n then "x" else "_")))
|
||||
(List.mapi (fun i _ -> i) ts)
|
||||
format_with_parens e1
|
||||
| Some s ->
|
||||
Format.fprintf fmt "%a.%a" format_with_parens e1 format_struct_field_name
|
||||
(fst (List.nth (Dcalc.Ast.StructMap.find s ctx.ctx_structs) n)))
|
||||
| EInj (e, n, en, _ts) ->
|
||||
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_enum_cons_name
|
||||
(fst (List.nth (Dcalc.Ast.EnumMap.find en ctx.ctx_enums) n))
|
||||
format_with_parens e
|
||||
| EMatch (e, es, e_name) ->
|
||||
Format.fprintf fmt "@[<hov 2>match@ %a@]@ with@\n%a" format_with_parens e
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n| ")
|
||||
(fun fmt (e, c) ->
|
||||
Format.fprintf fmt "%a %a" format_enum_cons_name c
|
||||
(fun fmt e ->
|
||||
match Pos.unmark e with
|
||||
| EAbs ((binder, _), _) ->
|
||||
let xs, body = Bindlib.unmbind binder in
|
||||
Format.fprintf fmt "%a ->@[<hov 2>@ %a@]"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@,")
|
||||
(fun fmt x -> Format.fprintf fmt "%a" format_var x))
|
||||
(Array.to_list xs) format_with_parens body
|
||||
| _ -> assert false
|
||||
(* should not happen *))
|
||||
e))
|
||||
(List.combine es (List.map fst (Dcalc.Ast.EnumMap.find e_name ctx.ctx_enums)))
|
||||
| ELit l -> Format.fprintf fmt "%a" format_lit (Pos.same_pos_as l e)
|
||||
| EApp ((EAbs ((binder, _), taus), _), args) ->
|
||||
let xs, body = Bindlib.unmbind binder in
|
||||
let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in
|
||||
let xs_tau_arg = List.map2 (fun (x, tau) arg -> (x, tau, arg)) xs_tau args in
|
||||
Format.fprintf fmt "%a%a"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "")
|
||||
(fun fmt (x, tau, arg) ->
|
||||
Format.fprintf fmt "@[<hov 2>let@ %a@ :@ %a@ =@ %a@]@ in@\n" format_var x format_typ
|
||||
tau format_with_parens arg))
|
||||
xs_tau_arg format_with_parens body
|
||||
| EAbs ((binder, _), taus) ->
|
||||
let xs, body = Bindlib.unmbind binder in
|
||||
let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in
|
||||
Format.fprintf fmt "@[<hov 2>fun@ %a ->@ %a@]"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
|
||||
(fun fmt (x, tau) ->
|
||||
Format.fprintf fmt "@[<hov 2>(%a:@ %a)@]" format_var x format_typ tau))
|
||||
xs_tau format_expr body
|
||||
| EApp ((EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), [ arg1; arg2 ]) ->
|
||||
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_binop (op, Pos.no_pos) format_with_parens
|
||||
arg1 format_with_parens arg2
|
||||
| EApp ((EOp (Binop op), _), [ arg1; arg2 ]) ->
|
||||
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1 format_binop
|
||||
(op, Pos.no_pos) format_with_parens arg2
|
||||
| EApp ((EApp ((EOp (Unop (D.Log (D.BeginCall, info))), _), [ f ]), _), [ arg ])
|
||||
when !Cli.trace_flag ->
|
||||
Format.fprintf fmt "(log_begin_call@ %a@ %a@ %a)" format_uid_list info format_with_parens f
|
||||
format_with_parens arg
|
||||
| EApp ((EOp (Unop (D.Log (D.VarDef tau, info))), _), [ arg1 ]) when !Cli.trace_flag ->
|
||||
Format.fprintf fmt "(log_variable_definition@ %a@ (%a)@ %a)" format_uid_list info
|
||||
typ_embedding_name (tau, Pos.no_pos) format_with_parens arg1
|
||||
| EApp ((EOp (Unop (D.Log (D.PosRecordIfTrueBool, _))), pos), [ arg1 ]) when !Cli.trace_flag ->
|
||||
Format.fprintf fmt
|
||||
"(log_decision_taken@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ start_column=%d;@ \
|
||||
end_line=%d; end_column=%d;@ law_headings=%a}@]@ %a)"
|
||||
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
|
||||
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos)
|
||||
format_with_parens arg1
|
||||
| EApp ((EOp (Unop (D.Log (D.EndCall, info))), _), [ arg1 ]) when !Cli.trace_flag ->
|
||||
Format.fprintf fmt "(log_end_call@ %a@ %a)" format_uid_list info format_with_parens arg1
|
||||
| EApp ((EOp (Unop (D.Log _)), _), [ arg1 ]) -> Format.fprintf fmt "%a" format_with_parens arg1
|
||||
| EApp ((EOp (Unop op), _), [ arg1 ]) ->
|
||||
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_unop (op, Pos.no_pos) format_with_parens arg1
|
||||
| EApp (f, args) ->
|
||||
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_with_parens f
|
||||
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") format_with_parens)
|
||||
args
|
||||
| EIfThenElse (e1, e2, e3) ->
|
||||
Format.fprintf fmt "@[<hov 2> if@ @[<hov 2>%a@]@ then@ @[<hov 2>%a@]@ else@ @[<hov 2>%a@]@]"
|
||||
format_with_parens e1 format_with_parens e2 format_with_parens e3
|
||||
| EOp (Ternop op) -> Format.fprintf fmt "%a" format_ternop (op, Pos.no_pos)
|
||||
| EOp (Binop op) -> Format.fprintf fmt "%a" format_binop (op, Pos.no_pos)
|
||||
| EOp (Unop op) -> Format.fprintf fmt "%a" format_unop (op, Pos.no_pos)
|
||||
| EAssert e' ->
|
||||
Format.fprintf fmt "@[<hov 2>if @ %a@ then@ ()@ else@ raise AssertionFailed@]"
|
||||
format_with_parens e'
|
||||
| ERaise exc -> Format.fprintf fmt "raise@ %a" format_exception (exc, Pos.get_position e)
|
||||
| ECatch (e1, exc, e2) ->
|
||||
Format.fprintf fmt "@[<hov 2>try@ %a@ with@ %a@ ->@ %a@]" format_with_parens e1
|
||||
format_exception
|
||||
(exc, Pos.get_position e)
|
||||
format_with_parens e2
|
||||
|
||||
let format_struct_embedding (fmt : Format.formatter)
|
||||
((struct_name, struct_fields) : D.StructName.t * (D.StructFieldName.t * D.typ Pos.marked) list)
|
||||
=
|
||||
if List.length struct_fields = 0 then
|
||||
Format.fprintf fmt "let embed_%a (_: %a) : runtime_value = Unit@\n@\n" format_struct_name
|
||||
struct_name format_struct_name struct_name
|
||||
else
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>let embed_%a (x: %a) : runtime_value =@ Struct([\"%a\"],@ @[<hov 2>[%a]@])@]@\n@\n"
|
||||
format_struct_name struct_name format_struct_name struct_name D.StructName.format_t
|
||||
struct_name
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n")
|
||||
(fun _fmt (struct_field, struct_field_type) ->
|
||||
Format.fprintf fmt "(\"%a\",@ %a@ x.%a)" D.StructFieldName.format_t struct_field
|
||||
typ_embedding_name struct_field_type format_struct_field_name struct_field))
|
||||
struct_fields
|
||||
|
||||
let format_enum_embedding (fmt : Format.formatter)
|
||||
((enum_name, enum_cases) : D.EnumName.t * (D.EnumConstructor.t * D.typ Pos.marked) list) =
|
||||
if List.length enum_cases = 0 then
|
||||
Format.fprintf fmt "let embed_%a (_: %a) : runtime_value = Unit@\n@\n" format_enum_name
|
||||
enum_name format_enum_name enum_name
|
||||
else
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>let embed_%a (x: %a) : runtime_value =@ Enum([\"%a\"],@ @[<hov 2>match x with@ \
|
||||
%a@])@]@\n\
|
||||
@\n"
|
||||
format_enum_name enum_name format_enum_name enum_name D.EnumName.format_t enum_name
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
||||
(fun _fmt (enum_cons, enum_cons_type) ->
|
||||
Format.fprintf fmt "@[<hov 2>| %a x ->@ (\"%a\", %a x)@]" format_enum_cons_name enum_cons
|
||||
D.EnumConstructor.format_t enum_cons typ_embedding_name enum_cons_type))
|
||||
enum_cases
|
||||
|
||||
let format_ctx (type_ordering : Scopelang.Dependency.TVertex.t list) (fmt : Format.formatter)
|
||||
(ctx : D.decl_ctx) : unit =
|
||||
let format_struct_decl fmt (struct_name, struct_fields) =
|
||||
if List.length struct_fields = 0 then
|
||||
Format.fprintf fmt "type %a = unit@\n@\n" format_struct_name struct_name
|
||||
else
|
||||
Format.fprintf fmt "type %a = {@\n@[<hov 2> %a@]@\n}@\n@\n" format_struct_name struct_name
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
||||
(fun _fmt (struct_field, struct_field_type) ->
|
||||
Format.fprintf fmt "%a:@ %a;" format_struct_field_name struct_field format_typ
|
||||
struct_field_type))
|
||||
struct_fields;
|
||||
if !Cli.trace_flag then format_struct_embedding fmt (struct_name, struct_fields)
|
||||
in
|
||||
let format_enum_decl fmt (enum_name, enum_cons) =
|
||||
if List.length enum_cons = 0 then
|
||||
Format.fprintf fmt "type %a = unit@\n@\n" format_enum_name enum_name
|
||||
else
|
||||
Format.fprintf fmt "type %a =@\n@[<hov 2> %a@]@\n@\n" format_enum_name enum_name
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
||||
(fun _fmt (enum_cons, enum_cons_type) ->
|
||||
Format.fprintf fmt "| %a@ of@ %a" format_enum_cons_name enum_cons format_typ
|
||||
enum_cons_type))
|
||||
enum_cons;
|
||||
if !Cli.trace_flag then format_enum_embedding fmt (enum_name, enum_cons)
|
||||
in
|
||||
let is_in_type_ordering s =
|
||||
List.exists
|
||||
(fun struct_or_enum ->
|
||||
match struct_or_enum with
|
||||
| Scopelang.Dependency.TVertex.Enum _ -> false
|
||||
| Scopelang.Dependency.TVertex.Struct s' -> s = s')
|
||||
type_ordering
|
||||
in
|
||||
let scope_structs =
|
||||
List.map
|
||||
(fun (s, _) -> Scopelang.Dependency.TVertex.Struct s)
|
||||
(Dcalc.Ast.StructMap.bindings
|
||||
(Dcalc.Ast.StructMap.filter (fun s _ -> not (is_in_type_ordering s)) ctx.ctx_structs))
|
||||
in
|
||||
List.iter
|
||||
(fun struct_or_enum ->
|
||||
match struct_or_enum with
|
||||
| Scopelang.Dependency.TVertex.Struct s ->
|
||||
Format.fprintf fmt "%a@\n@\n" format_struct_decl
|
||||
(s, Dcalc.Ast.StructMap.find s ctx.Dcalc.Ast.ctx_structs)
|
||||
| Scopelang.Dependency.TVertex.Enum e ->
|
||||
Format.fprintf fmt "%a@\n@\n" format_enum_decl
|
||||
(e, Dcalc.Ast.EnumMap.find e ctx.Dcalc.Ast.ctx_enums))
|
||||
(type_ordering @ scope_structs)
|
||||
|
||||
let format_program (fmt : Format.formatter) (p : Ast.program)
|
||||
(type_ordering : Scopelang.Dependency.TVertex.t list) : unit =
|
||||
Cli.style_flag := false;
|
||||
Format.fprintf fmt
|
||||
"# This file has been generated by the Catala compiler, do not edit!\n\
|
||||
@\n\
|
||||
from catala_runtime import *@\n\
|
||||
@\n\
|
||||
%a@\n\
|
||||
@\n\
|
||||
%a@?"
|
||||
(format_ctx type_ordering) p.decl_ctx
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n@\n")
|
||||
(fun fmt (name, e) ->
|
||||
Format.fprintf fmt "@[<hov 2>let@ %a@ =@ %a@]" format_var name (format_expr p.decl_ctx) e))
|
||||
p.scopes
|
||||
18
compiler/lcalc/to_python.mli
Normal file
18
compiler/lcalc/to_python.mli
Normal file
@ -0,0 +1,18 @@
|
||||
(* This file is part of the Catala compiler, a specification language for tax and social benefits
|
||||
computation rules. Copyright (C) 2021 Inria, contributor: Denis Merigoux
|
||||
<denis.merigoux@inria.fr>
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except
|
||||
in compliance with the License. You may obtain a copy of the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software distributed under the License
|
||||
is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express
|
||||
or implied. See the License for the specific language governing permissions and limitations under
|
||||
the License. *)
|
||||
|
||||
(** Formats a lambda calculus program into a valid Python program *)
|
||||
|
||||
val format_program : Format.formatter -> Ast.program -> Scopelang.Dependency.TVertex.t list -> unit
|
||||
(** Usage [format_program fmt p type_dependencies_ordering] *)
|
||||
@ -64,7 +64,7 @@ let backend =
|
||||
& info [] ~docv:"BACKEND"
|
||||
~doc:"Backend selection among: LaTeX, Makefile, Html, Interpret, OCaml, Dcalc, Scopelang")
|
||||
|
||||
type backend_option = Latex | Makefile | Html | Run | OCaml | Dcalc | Scopelang
|
||||
type backend_option = Latex | Makefile | Html | Run | OCaml | Python | Dcalc | Scopelang
|
||||
|
||||
let language =
|
||||
Arg.(
|
||||
|
||||
@ -49,7 +49,7 @@ val wrap_weaved_output : bool Cmdliner.Term.t
|
||||
|
||||
val backend : string Cmdliner.Term.t
|
||||
|
||||
type backend_option = Latex | Makefile | Html | Run | OCaml | Dcalc | Scopelang
|
||||
type backend_option = Latex | Makefile | Html | Run | OCaml | Python | Dcalc | Scopelang
|
||||
|
||||
val language : string option Cmdliner.Term.t
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user