2021-01-28 02:28:28 +03:00
|
|
|
(* 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
|
2022-08-12 23:42:39 +03:00
|
|
|
open Shared_ast
|
2021-01-28 02:28:28 +03:00
|
|
|
open Ast
|
2022-08-03 18:02:13 +03:00
|
|
|
open String_common
|
2021-02-12 19:20:14 +03:00
|
|
|
module D = Dcalc.Ast
|
2021-01-28 02:28:28 +03:00
|
|
|
|
2022-08-12 23:42:39 +03:00
|
|
|
let find_struct (s : StructName.t) (ctx : decl_ctx) :
|
|
|
|
(StructFieldName.t * typ Marked.pos) list =
|
|
|
|
try StructMap.find s ctx.ctx_structs
|
2022-02-04 16:30:42 +03:00
|
|
|
with Not_found ->
|
2022-08-12 23:42:39 +03:00
|
|
|
let s_name, pos = StructName.get_info s in
|
2022-03-08 15:04:27 +03:00
|
|
|
Errors.raise_spanned_error pos
|
|
|
|
"Internal Error: Structure %s was not found in the current environment."
|
|
|
|
s_name
|
2022-02-04 16:30:42 +03:00
|
|
|
|
2022-08-12 23:42:39 +03:00
|
|
|
let find_enum (en : EnumName.t) (ctx : decl_ctx) :
|
|
|
|
(EnumConstructor.t * typ Marked.pos) list =
|
|
|
|
try EnumMap.find en ctx.ctx_enums
|
2022-02-02 19:24:32 +03:00
|
|
|
with Not_found ->
|
2022-08-12 23:42:39 +03:00
|
|
|
let en_name, pos = EnumName.get_info en in
|
2022-03-08 15:04:27 +03:00
|
|
|
Errors.raise_spanned_error pos
|
|
|
|
"Internal Error: Enumeration %s was not found in the current environment."
|
|
|
|
en_name
|
2022-02-02 19:24:32 +03:00
|
|
|
|
2022-05-30 12:20:48 +03:00
|
|
|
let format_lit (fmt : Format.formatter) (l : lit Marked.pos) : unit =
|
|
|
|
match Marked.unmark l with
|
2022-08-12 23:42:39 +03:00
|
|
|
| LBool b -> Dcalc.Print.format_lit fmt (LBool b)
|
2021-03-05 21:16:56 +03:00
|
|
|
| LInt i ->
|
|
|
|
Format.fprintf fmt "integer_of_string@ \"%s\"" (Runtime.integer_to_string i)
|
2022-08-12 23:42:39 +03:00
|
|
|
| LUnit -> Dcalc.Print.format_lit fmt LUnit
|
2021-01-28 20:30:01 +03:00
|
|
|
| LRat i ->
|
|
|
|
Format.fprintf fmt "decimal_of_string \"%a\"" Dcalc.Print.format_lit
|
2022-08-12 23:42:39 +03:00
|
|
|
(LRat i)
|
2021-03-05 21:16:56 +03:00
|
|
|
| LMoney e ->
|
|
|
|
Format.fprintf fmt "money_of_cents_string@ \"%s\""
|
|
|
|
(Runtime.integer_to_string (Runtime.money_to_cents e))
|
2021-01-29 01:46:39 +03:00
|
|
|
| LDate d ->
|
2022-07-22 20:02:09 +03:00
|
|
|
Format.fprintf fmt "date_of_numbers (%d) (%d) (%d)"
|
2021-03-05 21:16:56 +03:00
|
|
|
(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))
|
2021-01-29 01:46:39 +03:00
|
|
|
| LDuration d ->
|
2021-06-20 23:07:39 +03:00
|
|
|
let years, months, days = Runtime.duration_to_years_months_days d in
|
2022-07-22 20:02:09 +03:00
|
|
|
Format.fprintf fmt "duration_of_numbers (%d) (%d) (%d)" years months days
|
2021-01-28 02:28:28 +03:00
|
|
|
|
2022-08-12 23:42:39 +03:00
|
|
|
let format_op_kind (fmt : Format.formatter) (k : op_kind) =
|
2021-01-28 02:28:28 +03:00
|
|
|
Format.fprintf fmt "%s"
|
2021-01-30 19:54:05 +03:00
|
|
|
(match k with
|
|
|
|
| KInt -> "!"
|
|
|
|
| KRat -> "&"
|
|
|
|
| KMoney -> "$"
|
|
|
|
| KDate -> "@"
|
|
|
|
| KDuration -> "^")
|
2021-01-28 02:28:28 +03:00
|
|
|
|
2022-08-12 23:42:39 +03:00
|
|
|
let format_binop (fmt : Format.formatter) (op : binop Marked.pos) :
|
2021-01-28 02:28:28 +03:00
|
|
|
unit =
|
2022-05-30 12:20:48 +03:00
|
|
|
match Marked.unmark op with
|
2021-01-28 02:28:28 +03:00
|
|
|
| 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" "="
|
2021-03-16 20:34:59 +03:00
|
|
|
| Neq | Xor -> Format.fprintf fmt "%s" "<>"
|
2021-01-28 02:28:28 +03:00
|
|
|
| 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
|
2021-07-08 17:27:46 +03:00
|
|
|
| Concat -> Format.fprintf fmt "@"
|
2021-01-29 01:46:39 +03:00
|
|
|
| Map -> Format.fprintf fmt "Array.map"
|
|
|
|
| Filter -> Format.fprintf fmt "array_filter"
|
2021-01-28 02:28:28 +03:00
|
|
|
|
2022-08-12 23:42:39 +03:00
|
|
|
let format_ternop (fmt : Format.formatter) (op : ternop Marked.pos) :
|
2021-01-28 02:28:28 +03:00
|
|
|
unit =
|
2022-05-30 12:20:48 +03:00
|
|
|
match Marked.unmark op with Fold -> Format.fprintf fmt "Array.fold_left"
|
2021-01-28 02:28:28 +03:00
|
|
|
|
2021-04-03 18:58:31 +03:00
|
|
|
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 =
|
2022-07-22 20:02:09 +03:00
|
|
|
let sanitize_quotes = Re.compile (Re.char '"') in
|
2021-04-03 18:58:31 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>[%a]@]"
|
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
|
2022-07-22 20:02:09 +03:00
|
|
|
(fun fmt info ->
|
|
|
|
Format.fprintf fmt "\"%s\""
|
|
|
|
(Re.replace sanitize_quotes ~f:(fun _ -> "\\\"") info)))
|
2021-04-03 18:58:31 +03:00
|
|
|
uids
|
|
|
|
|
2022-08-12 23:42:39 +03:00
|
|
|
let format_unop (fmt : Format.formatter) (op : unop Marked.pos) : unit
|
2021-01-28 02:28:28 +03:00
|
|
|
=
|
2022-05-30 12:20:48 +03:00
|
|
|
match Marked.unmark op with
|
2021-01-29 01:46:39 +03:00
|
|
|
| Minus k -> Format.fprintf fmt "~-%a" format_op_kind k
|
|
|
|
| Not -> Format.fprintf fmt "%s" "not"
|
2021-11-24 17:51:49 +03:00
|
|
|
| Log (_entry, _infos) ->
|
2022-05-30 12:20:48 +03:00
|
|
|
Errors.raise_spanned_error (Marked.get_mark op)
|
2022-02-18 17:47:54 +03:00
|
|
|
"Internal error: a log operator has not been caught by the expression \
|
|
|
|
match"
|
2021-01-29 01:46:39 +03:00
|
|
|
| Length -> Format.fprintf fmt "%s" "array_length"
|
2021-03-05 21:16:56 +03:00
|
|
|
| IntToRat -> Format.fprintf fmt "%s" "decimal_of_integer"
|
2022-07-19 12:48:27 +03:00
|
|
|
| MoneyToRat -> Format.fprintf fmt "%s" "decimal_of_money"
|
|
|
|
| RatToMoney -> Format.fprintf fmt "%s" "money_of_decimal"
|
2021-03-05 21:16:56 +03:00
|
|
|
| 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"
|
2022-07-21 15:11:56 +03:00
|
|
|
| FirstDayOfMonth -> Format.fprintf fmt "%s" "first_day_of_month"
|
|
|
|
| LastDayOfMonth -> Format.fprintf fmt "%s" "last_day_of_month"
|
2022-03-17 14:30:14 +03:00
|
|
|
| RoundMoney -> Format.fprintf fmt "%s" "money_round"
|
2022-04-29 22:18:15 +03:00
|
|
|
| RoundDecimal -> Format.fprintf fmt "%s" "decimal_round"
|
2021-01-28 02:28:28 +03:00
|
|
|
|
2021-03-10 18:50:54 +03:00
|
|
|
let avoid_keywords (s : string) : string =
|
2022-07-22 20:02:09 +03:00
|
|
|
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
|
2021-03-10 18:50:54 +03:00
|
|
|
|
2022-08-12 23:42:39 +03:00
|
|
|
let format_struct_name (fmt : Format.formatter) (v : StructName.t) :
|
2021-01-28 02:28:28 +03:00
|
|
|
unit =
|
2022-08-12 23:42:39 +03:00
|
|
|
Format.asprintf "%a" StructName.format_t v
|
2022-08-03 18:02:13 +03:00
|
|
|
|> to_ascii
|
|
|
|
|> to_snake_case
|
|
|
|
|> avoid_keywords
|
|
|
|
|> Format.fprintf fmt "%s"
|
2022-07-19 18:59:45 +03:00
|
|
|
|
2022-07-20 19:24:54 +03:00
|
|
|
let format_to_module_name
|
|
|
|
(fmt : Format.formatter)
|
2022-08-12 23:42:39 +03:00
|
|
|
(name : [< `Ename of EnumName.t | `Sname of StructName.t ]) =
|
2022-07-20 19:24:54 +03:00
|
|
|
(match name with
|
2022-08-12 23:42:39 +03:00
|
|
|
| `Ename v -> Format.asprintf "%a" EnumName.format_t v
|
|
|
|
| `Sname v -> Format.asprintf "%a" StructName.format_t v)
|
2022-08-03 18:02:13 +03:00
|
|
|
|> to_ascii
|
|
|
|
|> to_snake_case
|
|
|
|
|> avoid_keywords
|
|
|
|
|> String.split_on_char '_'
|
2022-07-12 15:10:53 +03:00
|
|
|
|> List.map String.capitalize_ascii
|
2022-07-19 18:59:45 +03:00
|
|
|
|> String.concat ""
|
|
|
|
|> Format.fprintf fmt "%s"
|
2021-01-28 20:30:01 +03:00
|
|
|
|
|
|
|
let format_struct_field_name
|
|
|
|
(fmt : Format.formatter)
|
2022-07-12 15:10:53 +03:00
|
|
|
((sname_opt, v) :
|
2022-08-12 23:42:39 +03:00
|
|
|
StructName.t option * StructFieldName.t) : unit =
|
2022-07-12 15:10:53 +03:00
|
|
|
(match sname_opt with
|
2022-07-20 19:24:54 +03:00
|
|
|
| Some sname ->
|
|
|
|
Format.fprintf fmt "%a.%s" format_to_module_name (`Sname sname)
|
2022-07-12 15:10:53 +03:00
|
|
|
| None -> Format.fprintf fmt "%s")
|
2021-03-10 18:50:54 +03:00
|
|
|
(avoid_keywords
|
2022-08-12 23:42:39 +03:00
|
|
|
(to_ascii (Format.asprintf "%a" StructFieldName.format_t v)))
|
2021-01-28 02:28:28 +03:00
|
|
|
|
2022-08-12 23:42:39 +03:00
|
|
|
let format_enum_name (fmt : Format.formatter) (v : EnumName.t) : unit
|
2021-01-28 02:28:28 +03:00
|
|
|
=
|
|
|
|
Format.fprintf fmt "%s"
|
2021-03-10 18:50:54 +03:00
|
|
|
(avoid_keywords
|
2022-08-03 18:02:13 +03:00
|
|
|
(to_snake_case
|
2022-08-12 23:42:39 +03:00
|
|
|
(to_ascii (Format.asprintf "%a" EnumName.format_t v))))
|
2021-01-28 20:30:01 +03:00
|
|
|
|
|
|
|
let format_enum_cons_name
|
|
|
|
(fmt : Format.formatter)
|
2022-08-12 23:42:39 +03:00
|
|
|
(v : EnumConstructor.t) : unit =
|
2021-03-10 18:50:54 +03:00
|
|
|
Format.fprintf fmt "%s"
|
|
|
|
(avoid_keywords
|
2022-08-12 23:42:39 +03:00
|
|
|
(to_ascii (Format.asprintf "%a" EnumConstructor.format_t v)))
|
2021-01-28 02:28:28 +03:00
|
|
|
|
2022-08-12 23:42:39 +03:00
|
|
|
let rec typ_embedding_name (fmt : Format.formatter) (ty : typ Marked.pos) :
|
2021-04-09 00:23:10 +03:00
|
|
|
unit =
|
2022-05-30 12:20:48 +03:00
|
|
|
match Marked.unmark ty with
|
2022-08-12 23:42:39 +03:00
|
|
|
| TLit TUnit -> Format.fprintf fmt "embed_unit"
|
|
|
|
| TLit TBool -> Format.fprintf fmt "embed_bool"
|
|
|
|
| TLit TInt -> Format.fprintf fmt "embed_integer"
|
|
|
|
| TLit TRat -> Format.fprintf fmt "embed_decimal"
|
|
|
|
| TLit TMoney -> Format.fprintf fmt "embed_money"
|
|
|
|
| TLit TDate -> Format.fprintf fmt "embed_date"
|
|
|
|
| TLit TDuration -> Format.fprintf fmt "embed_duration"
|
|
|
|
| TTuple (_, Some s_name) ->
|
2021-04-09 00:23:10 +03:00
|
|
|
Format.fprintf fmt "embed_%a" format_struct_name s_name
|
2022-08-12 23:42:39 +03:00
|
|
|
| TEnum (_, e_name) -> Format.fprintf fmt "embed_%a" format_enum_name e_name
|
|
|
|
| TArray ty -> Format.fprintf fmt "embed_array (%a)" typ_embedding_name ty
|
2021-04-09 00:23:10 +03:00
|
|
|
| _ -> Format.fprintf fmt "unembeddable"
|
|
|
|
|
2022-08-12 23:42:39 +03:00
|
|
|
let typ_needs_parens (e : typ Marked.pos) : bool =
|
2022-05-30 12:20:48 +03:00
|
|
|
match Marked.unmark e with TArrow _ | TArray _ -> true | _ -> false
|
2021-02-01 11:54:48 +03:00
|
|
|
|
2022-08-12 23:42:39 +03:00
|
|
|
let rec format_typ (fmt : Format.formatter) (typ : typ Marked.pos) :
|
2021-01-28 02:28:28 +03:00
|
|
|
unit =
|
|
|
|
let format_typ_with_parens
|
|
|
|
(fmt : Format.formatter)
|
2022-08-12 23:42:39 +03:00
|
|
|
(t : typ Marked.pos) =
|
2021-02-01 11:54:48 +03:00
|
|
|
if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t
|
|
|
|
else Format.fprintf fmt "%a" format_typ t
|
2021-01-28 02:28:28 +03:00
|
|
|
in
|
2022-05-30 12:20:48 +03:00
|
|
|
match Marked.unmark typ with
|
2021-01-28 02:28:28 +03:00
|
|
|
| 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 "@ *@ ")
|
2022-02-07 12:58:41 +03:00
|
|
|
format_typ_with_parens)
|
2021-01-28 02:28:28 +03:00
|
|
|
ts
|
2022-07-20 19:24:54 +03:00
|
|
|
| TTuple (_, Some s) ->
|
|
|
|
Format.fprintf fmt "%a.t" format_to_module_name (`Sname s)
|
2022-08-12 23:42:39 +03:00
|
|
|
| TEnum ([t], e) when EnumName.compare e Ast.option_enum = 0 ->
|
2022-02-21 13:58:26 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>(%a)@] %a" format_typ_with_parens t
|
|
|
|
format_enum_name e
|
2022-08-12 23:42:39 +03:00
|
|
|
| TEnum (_, e) when EnumName.compare e Ast.option_enum = 0 ->
|
2022-05-30 12:20:48 +03:00
|
|
|
Errors.raise_spanned_error (Marked.get_mark typ)
|
2022-02-21 13:58:26 +03:00
|
|
|
"Internal Error: found an typing parameter for an eoption type of the \
|
2022-07-22 19:04:16 +03:00
|
|
|
wrong length."
|
2022-07-21 16:57:02 +03:00
|
|
|
| TEnum (_ts, e) -> Format.fprintf fmt "%a.t" format_to_module_name (`Ename e)
|
2021-01-28 02:28:28 +03:00
|
|
|
| TArrow (t1, t2) ->
|
2021-02-01 11:54:48 +03:00
|
|
|
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
|
2021-01-28 02:28:28 +03:00
|
|
|
| TAny -> Format.fprintf fmt "_"
|
|
|
|
|
2022-06-23 15:06:11 +03:00
|
|
|
let format_var (fmt : Format.formatter) (v : 'm var) : unit =
|
2022-08-03 18:02:13 +03:00
|
|
|
let lowercase_name = to_snake_case (to_ascii (Bindlib.name_of v)) in
|
2021-01-28 15:58:59 +03:00
|
|
|
let lowercase_name =
|
|
|
|
Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.")
|
|
|
|
~subst:(fun _ -> "_dot_")
|
|
|
|
lowercase_name
|
|
|
|
in
|
2021-03-10 18:50:54 +03:00
|
|
|
let lowercase_name = avoid_keywords (to_ascii lowercase_name) in
|
2022-02-04 16:30:42 +03:00
|
|
|
if
|
|
|
|
List.mem lowercase_name ["handle_default"; "handle_default_opt"]
|
2022-08-03 18:02:13 +03:00
|
|
|
|| begins_with_uppercase (Bindlib.name_of v)
|
2022-02-04 16:30:42 +03:00
|
|
|
then Format.fprintf fmt "%s" lowercase_name
|
2021-02-01 11:54:48 +03:00
|
|
|
else if lowercase_name = "_" then Format.fprintf fmt "%s" lowercase_name
|
2022-08-03 18:02:13 +03:00
|
|
|
else (
|
|
|
|
Cli.debug_print "lowercase_name: %s " lowercase_name;
|
|
|
|
Format.fprintf fmt "%s_" lowercase_name)
|
2021-01-28 02:28:28 +03:00
|
|
|
|
2022-06-23 15:06:11 +03:00
|
|
|
let needs_parens (e : 'm marked_expr) : bool =
|
2022-05-30 12:20:48 +03:00
|
|
|
match Marked.unmark e with
|
2021-04-03 12:49:13 +03:00
|
|
|
| EApp ((EAbs (_, _), _), _)
|
|
|
|
| ELit (LBool _ | LUnit)
|
|
|
|
| EVar _ | ETuple _ | EOp _ ->
|
|
|
|
false
|
2021-02-01 11:54:48 +03:00
|
|
|
| _ -> true
|
2021-01-28 02:28:28 +03:00
|
|
|
|
2022-05-30 12:20:48 +03:00
|
|
|
let format_exception (fmt : Format.formatter) (exc : except Marked.pos) : unit =
|
|
|
|
match Marked.unmark exc with
|
2022-07-29 18:04:34 +03:00
|
|
|
| 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)
|
2021-06-09 01:21:06 +03:00
|
|
|
| EmptyError -> Format.fprintf fmt "EmptyError"
|
|
|
|
| Crash -> Format.fprintf fmt "Crash"
|
|
|
|
| NoValueProvided ->
|
2022-05-30 12:20:48 +03:00
|
|
|
let pos = Marked.get_mark exc in
|
2021-06-09 01:21:06 +03:00
|
|
|
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)
|
|
|
|
|
2021-01-28 02:28:28 +03:00
|
|
|
let rec format_expr
|
2022-08-12 23:42:39 +03:00
|
|
|
(ctx : decl_ctx)
|
2021-01-28 02:28:28 +03:00
|
|
|
(fmt : Format.formatter)
|
2022-06-23 15:06:11 +03:00
|
|
|
(e : 'm marked_expr) : unit =
|
2021-01-28 02:28:28 +03:00
|
|
|
let format_expr = format_expr ctx in
|
2022-06-23 15:06:11 +03:00
|
|
|
let format_with_parens (fmt : Format.formatter) (e : 'm marked_expr) =
|
2021-01-28 02:28:28 +03:00
|
|
|
if needs_parens e then Format.fprintf fmt "(%a)" format_expr e
|
|
|
|
else Format.fprintf fmt "%a" format_expr e
|
|
|
|
in
|
2022-05-30 12:20:48 +03:00
|
|
|
match Marked.unmark e with
|
2022-06-03 17:40:03 +03:00
|
|
|
| EVar v -> Format.fprintf fmt "%a" format_var v
|
2021-01-28 02:28:28 +03:00
|
|
|
| ETuple (es, None) ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>(%a)@]"
|
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
2021-02-01 11:54:48 +03:00
|
|
|
(fun fmt e -> Format.fprintf fmt "%a" format_with_parens e))
|
2021-01-28 02:28:28 +03:00
|
|
|
es
|
|
|
|
| ETuple (es, Some s) ->
|
2021-02-03 12:53:21 +03:00
|
|
|
if List.length es = 0 then Format.fprintf fmt "()"
|
|
|
|
else
|
|
|
|
Format.fprintf fmt "{@[<hov 2>%a@]}"
|
2021-01-28 02:28:28 +03:00
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
|
2021-02-03 12:53:21 +03:00
|
|
|
(fun fmt (e, struct_field) ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a =@ %a@]" format_struct_field_name
|
2022-07-12 15:10:53 +03:00
|
|
|
(Some s, struct_field) format_with_parens e))
|
2022-02-02 19:24:32 +03:00
|
|
|
(List.combine es (List.map fst (find_struct s ctx)))
|
2021-01-28 02:28:28 +03:00
|
|
|
| EArray es ->
|
2021-01-29 01:46:39 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>[|%a|]@]"
|
2021-01-28 02:28:28 +03:00
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
|
2021-02-01 11:54:48 +03:00
|
|
|
(fun fmt e -> Format.fprintf fmt "%a" format_with_parens e))
|
2021-01-28 02:28:28 +03:00
|
|
|
es
|
2021-01-28 15:58:59 +03:00
|
|
|
| ETupleAccess (e1, n, s, ts) -> (
|
2021-01-28 02:28:28 +03:00
|
|
|
match s with
|
2021-01-28 15:58:59 +03:00
|
|
|
| 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)
|
2021-02-01 11:54:48 +03:00
|
|
|
format_with_parens e1
|
2021-01-28 02:28:28 +03:00
|
|
|
| Some s ->
|
2021-02-01 11:54:48 +03:00
|
|
|
Format.fprintf fmt "%a.%a" format_with_parens e1 format_struct_field_name
|
2022-07-12 15:10:53 +03:00
|
|
|
(Some s, fst (List.nth (find_struct s ctx) n)))
|
2021-01-28 02:28:28 +03:00
|
|
|
| EInj (e, n, en, _ts) ->
|
2022-07-21 16:57:02 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a.%a@ %a@]" format_to_module_name (`Ename en)
|
|
|
|
format_enum_cons_name
|
2022-02-02 19:24:32 +03:00
|
|
|
(fst (List.nth (find_enum en ctx) n))
|
2021-02-01 11:54:48 +03:00
|
|
|
format_with_parens e
|
2021-01-28 02:28:28 +03:00
|
|
|
| EMatch (e, es, e_name) ->
|
2022-08-04 18:37:27 +03:00
|
|
|
Format.fprintf fmt "@[<hv>@[<hov 2>match@ %a@]@ with@\n| %a@]"
|
|
|
|
format_with_parens e
|
2021-01-28 02:28:28 +03:00
|
|
|
(Format.pp_print_list
|
2022-08-04 18:37:27 +03:00
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ | ")
|
2021-01-28 02:28:28 +03:00
|
|
|
(fun fmt (e, c) ->
|
2022-08-04 18:37:27 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a.%a %a@]" format_to_module_name
|
|
|
|
(`Ename e_name) format_enum_cons_name c
|
2021-01-28 02:28:28 +03:00
|
|
|
(fun fmt e ->
|
2022-05-30 12:20:48 +03:00
|
|
|
match Marked.unmark e with
|
2022-06-03 17:40:03 +03:00
|
|
|
| EAbs (binder, _) ->
|
2021-01-28 02:28:28 +03:00
|
|
|
let xs, body = Bindlib.unmbind binder in
|
2022-08-04 18:37:27 +03:00
|
|
|
Format.fprintf fmt "%a ->@ %a"
|
2021-01-28 02:28:28 +03:00
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "@,")
|
|
|
|
(fun fmt x -> Format.fprintf fmt "%a" format_var x))
|
2021-02-01 11:54:48 +03:00
|
|
|
(Array.to_list xs) format_with_parens body
|
2021-01-28 02:28:28 +03:00
|
|
|
| _ -> assert false
|
|
|
|
(* should not happen *))
|
|
|
|
e))
|
2022-02-02 19:24:32 +03:00
|
|
|
(List.combine es (List.map fst (find_enum e_name ctx)))
|
2022-08-12 23:42:39 +03:00
|
|
|
| ELit l -> Format.fprintf fmt "%a" format_lit (Marked.mark (Expr.pos e) l)
|
2022-06-03 17:40:03 +03:00
|
|
|
| EApp ((EAbs (binder, taus), _), args) ->
|
2021-01-28 02:28:28 +03:00
|
|
|
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
|
2022-02-04 16:30:42 +03:00
|
|
|
Format.fprintf fmt "(%a%a)"
|
2021-01-28 02:28:28 +03:00
|
|
|
(Format.pp_print_list
|
2021-02-02 01:35:15 +03:00
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "")
|
2021-01-28 02:28:28 +03:00
|
|
|
(fun fmt (x, tau, arg) ->
|
2021-02-01 11:54:48 +03:00
|
|
|
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
|
2022-06-03 17:40:03 +03:00
|
|
|
| EAbs (binder, taus) ->
|
2021-01-28 02:28:28 +03:00
|
|
|
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
|
2022-08-12 23:42:39 +03:00
|
|
|
((EOp (Binop ((Map | Filter) as op)), _), [arg1; arg2])
|
2021-01-28 02:28:28 +03:00
|
|
|
->
|
2021-01-28 20:30:01 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_binop (op, Pos.no_pos)
|
|
|
|
format_with_parens arg1 format_with_parens arg2
|
2021-01-28 02:28:28 +03:00
|
|
|
| EApp ((EOp (Binop op), _), [arg1; arg2]) ->
|
2021-01-28 20:30:01 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1
|
2021-01-28 02:28:28 +03:00
|
|
|
format_binop (op, Pos.no_pos) format_with_parens arg2
|
2022-08-12 23:42:39 +03:00
|
|
|
| EApp ((EApp ((EOp (Unop (Log (BeginCall, info))), _), [f]), _), [arg])
|
2021-04-03 18:58:31 +03:00
|
|
|
when !Cli.trace_flag ->
|
2022-06-15 15:34:15 +03:00
|
|
|
Format.fprintf fmt "(log_begin_call@ %a@ %a)@ %a" format_uid_list info
|
2021-02-01 11:54:48 +03:00
|
|
|
format_with_parens f format_with_parens arg
|
2022-08-12 23:42:39 +03:00
|
|
|
| EApp ((EOp (Unop (Log (VarDef tau, info))), _), [arg1])
|
2021-04-03 18:58:31 +03:00
|
|
|
when !Cli.trace_flag ->
|
2021-04-09 00:23:10 +03:00
|
|
|
Format.fprintf fmt "(log_variable_definition@ %a@ (%a)@ %a)" format_uid_list
|
|
|
|
info typ_embedding_name (tau, Pos.no_pos) format_with_parens arg1
|
2022-08-12 23:42:39 +03:00
|
|
|
| EApp ((EOp (Unop (Log (PosRecordIfTrueBool, _))), m), [arg1])
|
2021-04-03 18:58:31 +03:00
|
|
|
when !Cli.trace_flag ->
|
2022-08-12 23:42:39 +03:00
|
|
|
let pos = Expr.mark_pos m in
|
2021-04-03 18:58:31 +03:00
|
|
|
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
|
2022-08-12 23:42:39 +03:00
|
|
|
| EApp ((EOp (Unop (Log (EndCall, info))), _), [arg1])
|
2021-04-03 18:58:31 +03:00
|
|
|
when !Cli.trace_flag ->
|
2021-04-05 20:06:32 +03:00
|
|
|
Format.fprintf fmt "(log_end_call@ %a@ %a)" format_uid_list info
|
2021-04-03 18:58:31 +03:00
|
|
|
format_with_parens arg1
|
2022-08-12 23:42:39 +03:00
|
|
|
| EApp ((EOp (Unop (Log _)), _), [arg1]) ->
|
2021-02-01 11:54:48 +03:00
|
|
|
Format.fprintf fmt "%a" format_with_parens arg1
|
2021-01-28 02:28:28 +03:00
|
|
|
| EApp ((EOp (Unop op), _), [arg1]) ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_unop (op, Pos.no_pos)
|
|
|
|
format_with_parens arg1
|
2022-07-29 18:04:34 +03:00
|
|
|
| EApp ((EVar x, pos), args)
|
2022-07-28 11:36:36 +03:00
|
|
|
when Var.compare x (Var.translate Ast.handle_default) = 0
|
|
|
|
|| Var.compare x (Var.translate Ast.handle_default_opt) = 0 ->
|
2022-07-29 18:04:34 +03:00
|
|
|
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
|
2022-08-12 23:42:39 +03:00
|
|
|
(Pos.get_file (Expr.mark_pos pos))
|
|
|
|
(Pos.get_start_line (Expr.mark_pos pos))
|
|
|
|
(Pos.get_start_column (Expr.mark_pos pos))
|
|
|
|
(Pos.get_end_line (Expr.mark_pos pos))
|
|
|
|
(Pos.get_end_column (Expr.mark_pos pos))
|
2022-07-29 18:04:34 +03:00
|
|
|
format_string_list
|
2022-08-12 23:42:39 +03:00
|
|
|
(Pos.get_law_info (Expr.mark_pos pos))
|
2022-07-29 18:04:34 +03:00
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
|
|
|
|
format_with_parens)
|
|
|
|
args
|
2021-01-28 02:28:28 +03:00
|
|
|
| EApp (f, args) ->
|
2021-02-01 11:54:48 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_with_parens f
|
2021-01-28 02:28:28 +03:00
|
|
|
(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@]@]"
|
2021-02-01 11:54:48 +03:00
|
|
|
format_with_parens e1 format_with_parens e2 format_with_parens e3
|
2021-01-28 02:28:28 +03:00
|
|
|
| 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)
|
2021-01-30 19:54:05 +03:00
|
|
|
| EAssert e' ->
|
2021-04-03 15:38:38 +03:00
|
|
|
Format.fprintf fmt
|
2022-08-04 18:37:27 +03:00
|
|
|
"@[<hov 2>if@ %a@ then@ ()@ else@ raise (AssertionFailed @[<hov \
|
2022-07-29 18:04:34 +03:00
|
|
|
2>{filename = \"%s\";@ start_line=%d;@ start_column=%d;@ end_line=%d; \
|
|
|
|
end_column=%d;@ law_headings=%a}@])@]"
|
2021-02-01 11:54:48 +03:00
|
|
|
format_with_parens e'
|
2022-08-12 23:42:39 +03:00
|
|
|
(Pos.get_file (Expr.pos e'))
|
|
|
|
(Pos.get_start_line (Expr.pos e'))
|
|
|
|
(Pos.get_start_column (Expr.pos e'))
|
|
|
|
(Pos.get_end_line (Expr.pos e'))
|
|
|
|
(Pos.get_end_column (Expr.pos e'))
|
2022-07-29 18:04:34 +03:00
|
|
|
format_string_list
|
2022-08-12 23:42:39 +03:00
|
|
|
(Pos.get_law_info (Expr.pos e'))
|
|
|
|
| ERaise exc -> Format.fprintf fmt "raise@ %a" format_exception (exc, Expr.pos e)
|
2021-01-28 02:28:28 +03:00
|
|
|
| ECatch (e1, exc, e2) ->
|
2022-08-04 18:37:27 +03:00
|
|
|
Format.fprintf fmt
|
|
|
|
"@,@[<hv>@[<hov 2>try@ %a@]@ with@]@ @[<hov 2>%a@ ->@ %a@]"
|
|
|
|
format_with_parens e1 format_exception
|
2022-08-12 23:42:39 +03:00
|
|
|
(exc, Expr.pos e)
|
2021-06-09 01:21:06 +03:00
|
|
|
format_with_parens e2
|
2021-01-28 02:28:28 +03:00
|
|
|
|
2021-04-09 00:23:10 +03:00
|
|
|
let format_struct_embedding
|
|
|
|
(fmt : Format.formatter)
|
|
|
|
((struct_name, struct_fields) :
|
2022-08-12 23:42:39 +03:00
|
|
|
StructName.t * (StructFieldName.t * typ Marked.pos) list) =
|
2021-04-09 00:23:10 +03:00
|
|
|
if List.length struct_fields = 0 then
|
2022-07-12 15:10:53 +03:00
|
|
|
Format.fprintf fmt "let embed_%a (_: %a.t) : runtime_value = Unit@\n@\n"
|
2022-07-20 19:24:54 +03:00
|
|
|
format_struct_name struct_name format_to_module_name (`Sname struct_name)
|
2021-04-09 00:23:10 +03:00
|
|
|
else
|
|
|
|
Format.fprintf fmt
|
2022-07-12 15:10:53 +03:00
|
|
|
"@[<hov 2>let embed_%a (x: %a.t) : runtime_value =@ Struct([\"%a\"],@ \
|
2021-04-09 00:23:10 +03:00
|
|
|
@[<hov 2>[%a]@])@]@\n\
|
|
|
|
@\n"
|
2022-07-20 19:24:54 +03:00
|
|
|
format_struct_name struct_name format_to_module_name (`Sname struct_name)
|
2022-08-12 23:42:39 +03:00
|
|
|
StructName.format_t struct_name
|
2021-04-09 00:23:10 +03:00
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n")
|
|
|
|
(fun _fmt (struct_field, struct_field_type) ->
|
2022-08-12 23:42:39 +03:00
|
|
|
Format.fprintf fmt "(\"%a\",@ %a@ x.%a)" StructFieldName.format_t
|
2021-04-09 00:23:10 +03:00
|
|
|
struct_field typ_embedding_name struct_field_type
|
2022-07-12 15:10:53 +03:00
|
|
|
format_struct_field_name
|
|
|
|
(Some struct_name, struct_field)))
|
2021-04-09 00:23:10 +03:00
|
|
|
struct_fields
|
|
|
|
|
|
|
|
let format_enum_embedding
|
|
|
|
(fmt : Format.formatter)
|
|
|
|
((enum_name, enum_cases) :
|
2022-08-12 23:42:39 +03:00
|
|
|
EnumName.t * (EnumConstructor.t * typ Marked.pos) list) =
|
2021-04-09 00:23:10 +03:00
|
|
|
if List.length enum_cases = 0 then
|
2022-07-21 16:57:02 +03:00
|
|
|
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
|
2021-04-09 00:23:10 +03:00
|
|
|
else
|
|
|
|
Format.fprintf fmt
|
2022-08-04 18:37:27 +03:00
|
|
|
"@[<hv 2>@[<hov 2>let embed_%a@ @[<hov 2>(x:@ %a.t)@]@ : runtime_value \
|
|
|
|
=@]@ Enum([\"%a\"],@ @[<hov 2>match x with@ %a@])@]@\n\
|
2021-04-09 00:23:10 +03:00
|
|
|
@\n"
|
2022-07-21 16:57:02 +03:00
|
|
|
format_enum_name enum_name format_to_module_name (`Ename enum_name)
|
2022-08-12 23:42:39 +03:00
|
|
|
EnumName.format_t enum_name
|
2021-04-09 00:23:10 +03:00
|
|
|
(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)@]"
|
2022-08-12 23:42:39 +03:00
|
|
|
format_enum_cons_name enum_cons EnumConstructor.format_t
|
2021-04-09 00:23:10 +03:00
|
|
|
enum_cons typ_embedding_name enum_cons_type))
|
|
|
|
enum_cases
|
|
|
|
|
2021-01-29 01:46:39 +03:00
|
|
|
let format_ctx
|
|
|
|
(type_ordering : Scopelang.Dependency.TVertex.t list)
|
|
|
|
(fmt : Format.formatter)
|
2022-08-12 23:42:39 +03:00
|
|
|
(ctx : decl_ctx) : unit =
|
2021-01-29 01:46:39 +03:00
|
|
|
let format_struct_decl fmt (struct_name, struct_fields) =
|
2021-02-03 12:53:21 +03:00
|
|
|
if List.length struct_fields = 0 then
|
2022-07-12 15:10:53 +03:00
|
|
|
Format.fprintf fmt
|
2022-08-04 18:37:27 +03:00
|
|
|
"@[<v 2>module %a = struct@\n@[<hov 2>type t = unit@]@]@\nend@\n"
|
2022-07-20 19:24:54 +03:00
|
|
|
format_to_module_name (`Sname struct_name)
|
2021-02-03 12:53:21 +03:00
|
|
|
else
|
2022-07-12 15:10:53 +03:00
|
|
|
Format.fprintf fmt
|
2022-08-04 18:37:27 +03:00
|
|
|
"@[<v>@[<v 2>module %a = struct@ @[<hv 2>type t = {@,\
|
|
|
|
%a@;\
|
|
|
|
<0-2>}@]@]@ end@]@\n"
|
2022-07-20 19:24:54 +03:00
|
|
|
format_to_module_name (`Sname struct_name)
|
2021-02-03 12:53:21 +03:00
|
|
|
(Format.pp_print_list
|
2022-08-04 18:37:27 +03:00
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
|
2021-02-03 12:53:21 +03:00
|
|
|
(fun _fmt (struct_field, struct_field_type) ->
|
2022-08-04 18:37:27 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a:@ %a@]" format_struct_field_name
|
2022-07-12 15:10:53 +03:00
|
|
|
(None, struct_field) format_typ struct_field_type))
|
2021-04-09 00:23:10 +03:00
|
|
|
struct_fields;
|
|
|
|
if !Cli.trace_flag then
|
|
|
|
format_struct_embedding fmt (struct_name, struct_fields)
|
2021-01-29 01:46:39 +03:00
|
|
|
in
|
|
|
|
let format_enum_decl fmt (enum_name, enum_cons) =
|
2022-07-21 16:57:02 +03:00
|
|
|
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) ->
|
2022-08-04 18:37:27 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>| %a@ of@ %a@]" format_enum_cons_name
|
|
|
|
enum_cons format_typ enum_cons_type))
|
2022-07-21 16:57:02 +03:00
|
|
|
enum_cons;
|
2021-04-09 00:23:10 +03:00
|
|
|
if !Cli.trace_flag then format_enum_embedding fmt (enum_name, enum_cons)
|
2021-01-29 01:46:39 +03:00
|
|
|
in
|
2021-01-29 18:24:20 +03:00
|
|
|
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)
|
2022-08-12 23:42:39 +03:00
|
|
|
(StructMap.bindings
|
|
|
|
(StructMap.filter
|
2021-01-29 18:24:20 +03:00
|
|
|
(fun s _ -> not (is_in_type_ordering s))
|
|
|
|
ctx.ctx_structs))
|
|
|
|
in
|
2021-01-29 01:46:39 +03:00
|
|
|
List.iter
|
|
|
|
(fun struct_or_enum ->
|
|
|
|
match struct_or_enum with
|
|
|
|
| Scopelang.Dependency.TVertex.Struct s ->
|
2022-07-12 15:10:53 +03:00
|
|
|
Format.fprintf fmt "%a@\n" format_struct_decl (s, find_struct s ctx)
|
2021-01-29 01:46:39 +03:00
|
|
|
| Scopelang.Dependency.TVertex.Enum e ->
|
2022-07-12 15:10:53 +03:00
|
|
|
Format.fprintf fmt "%a@\n" format_enum_decl (e, find_enum e ctx))
|
2021-01-29 18:24:20 +03:00
|
|
|
(type_ordering @ scope_structs)
|
2021-01-28 02:28:28 +03:00
|
|
|
|
2022-04-26 17:06:36 +03:00
|
|
|
let rec format_scope_body_expr
|
2022-08-12 23:42:39 +03:00
|
|
|
(ctx : decl_ctx)
|
2022-04-26 17:06:36 +03:00
|
|
|
(fmt : Format.formatter)
|
2022-08-12 23:42:39 +03:00
|
|
|
(scope_lets : ('m Ast.expr, 'm) scope_body_expr) : unit =
|
2022-04-26 17:06:36 +03:00
|
|
|
match scope_lets with
|
2022-08-12 23:42:39 +03:00
|
|
|
| Result e -> format_expr ctx fmt e
|
|
|
|
| ScopeLet scope_let ->
|
2022-04-26 17:06:36 +03:00
|
|
|
let scope_let_var, scope_let_next =
|
|
|
|
Bindlib.unbind scope_let.scope_let_next
|
|
|
|
in
|
|
|
|
Format.fprintf fmt "@[<hov 2>let %a: %a = %a in@]@\n%a" format_var
|
|
|
|
scope_let_var format_typ scope_let.scope_let_typ (format_expr ctx)
|
|
|
|
scope_let.scope_let_expr
|
|
|
|
(format_scope_body_expr ctx)
|
|
|
|
scope_let_next
|
|
|
|
|
|
|
|
let rec format_scopes
|
2022-08-12 23:42:39 +03:00
|
|
|
(ctx : decl_ctx)
|
2022-04-26 17:06:36 +03:00
|
|
|
(fmt : Format.formatter)
|
2022-08-12 23:42:39 +03:00
|
|
|
(scopes : ('m Ast.expr, 'm) scopes) : unit =
|
2022-04-26 17:06:36 +03:00
|
|
|
match scopes with
|
2022-08-12 23:42:39 +03:00
|
|
|
| Nil -> ()
|
|
|
|
| ScopeDef scope_def ->
|
2022-04-26 17:06:36 +03:00
|
|
|
let scope_input_var, scope_body_expr =
|
|
|
|
Bindlib.unbind scope_def.scope_body.scope_body_expr
|
|
|
|
in
|
|
|
|
let scope_var, scope_next = Bindlib.unbind scope_def.scope_next in
|
2022-07-12 15:10:53 +03:00
|
|
|
Format.fprintf fmt "@\n@\n@[<hov 2>let %a (%a: %a.t) : %a.t =@\n%a@]%a"
|
2022-07-20 19:24:54 +03:00
|
|
|
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)
|
2022-04-26 17:06:36 +03:00
|
|
|
(format_scope_body_expr ctx)
|
|
|
|
scope_body_expr (format_scopes ctx) scope_next
|
|
|
|
|
2021-01-29 01:46:39 +03:00
|
|
|
let format_program
|
|
|
|
(fmt : Format.formatter)
|
2022-06-23 15:06:11 +03:00
|
|
|
(p : 'm Ast.program)
|
2021-01-29 01:46:39 +03:00
|
|
|
(type_ordering : Scopelang.Dependency.TVertex.t list) : unit =
|
2022-07-20 17:51:28 +03:00
|
|
|
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\
|
2022-08-04 18:37:27 +03:00
|
|
|
%a%a@\n\
|
|
|
|
@?"
|
2022-07-20 17:51:28 +03:00
|
|
|
(format_ctx type_ordering) p.decl_ctx (format_scopes p.decl_ctx)
|
|
|
|
p.scopes)
|