catala/compiler/dcalc/print.ml

287 lines
13 KiB
OCaml
Raw Normal View History

(* 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. *)
2021-01-21 23:33:04 +03:00
open Utils
2020-11-26 12:38:13 +03:00
open Ast
let typ_needs_parens (e : typ Pos.marked) : bool =
2020-12-28 01:53:02 +03:00
match Pos.unmark e with TArrow _ | TArray _ -> true | _ -> false
2021-01-29 13:42:19 +03:00
let is_uppercase (x : CamomileLibraryDefault.Camomile.UChar.t) : bool =
2021-01-28 20:30:01 +03:00
try
2021-01-29 13:42:19 +03:00
match CamomileLibraryDefault.Camomile.UCharInfo.general_category x with
2021-01-28 20:30:01 +03:00
| `Ll -> false
| `Lu -> true
| _ -> false
with _ -> true
2021-01-29 13:42:19 +03:00
let begins_with_uppercase (s : string) : bool =
let first_letter = CamomileLibraryDefault.Camomile.UTF8.get s 0 in
is_uppercase first_letter
2021-01-09 23:03:32 +03:00
let format_uid_list (fmt : Format.formatter) (infos : Uid.MarkedString.info list) : unit =
Format.fprintf fmt "%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
(fun fmt info ->
Format.fprintf fmt "%s"
2021-01-13 14:04:14 +03:00
(Utils.Cli.print_with_style
2021-01-28 20:30:01 +03:00
(if begins_with_uppercase (Pos.unmark info) then [ ANSITerminal.red ] else [])
2021-01-09 23:03:32 +03:00
"%s"
(Format.asprintf "%a" Utils.Uid.MarkedString.format_info info))))
infos
let format_keyword (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%s" (Utils.Cli.print_with_style [ ANSITerminal.red ] "%s" s)
let format_base_type (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%s" (Utils.Cli.print_with_style [ ANSITerminal.yellow ] "%s" s)
let format_punctuation (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%s" (Utils.Cli.print_with_style [ ANSITerminal.cyan ] "%s" s)
2021-03-12 21:37:00 +03:00
let format_operator (fmt : Format.formatter) (s : string) : unit =
Format.fprintf fmt "%s" (Utils.Cli.print_with_style [ ANSITerminal.green ] "%s" s)
2020-12-10 13:35:56 +03:00
let format_tlit (fmt : Format.formatter) (l : typ_lit) : unit =
format_base_type fmt
(match l with
| TUnit -> "unit"
| TBool -> "bool"
| TInt -> "integer"
| TRat -> "decimal"
| TMoney -> "money"
| TDuration -> "duration"
| TDate -> "date")
2020-12-10 13:35:56 +03:00
2021-01-14 02:17:24 +03:00
let rec format_typ (ctx : Ast.decl_ctx) (fmt : Format.formatter) (typ : typ Pos.marked) : unit =
let format_typ = format_typ ctx in
let format_typ_with_parens (fmt : Format.formatter) (t : typ Pos.marked) =
if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t
else Format.fprintf fmt "%a" format_typ t
in
match Pos.unmark typ with
2020-12-10 13:35:56 +03:00
| TLit l -> Format.fprintf fmt "%a" format_tlit l
2021-01-14 02:17:24 +03:00
| TTuple (ts, None) ->
2021-01-28 02:28:28 +03:00
Format.fprintf fmt "@[<hov 2>(%a)@]"
2021-01-14 02:17:24 +03:00
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ *@ ")
(fun fmt t -> Format.fprintf fmt "%a" format_typ t))
2020-12-03 22:11:41 +03:00
ts
2021-12-10 19:55:24 +03:00
| TTuple (args, Some s) ->
Format.fprintf fmt "%a [%a]" Ast.StructName.format_t s
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ |@ ") format_typ)
args
| TEnum (_, e) -> Format.fprintf fmt "%a" Ast.EnumName.format_t e
2020-11-27 18:27:10 +03:00
| TArrow (t1, t2) ->
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" format_typ_with_parens t1 format_punctuation ""
format_typ t2
2021-03-12 21:37:00 +03:00
| TArray t1 -> Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_base_type "array" format_typ t1
2020-12-30 00:26:10 +03:00
| TAny -> Format.fprintf fmt "any"
2020-11-26 12:38:13 +03:00
(* (EmileRolley) NOTE: seems to be factorizable with Lcalc.Print.format_lit. *)
2020-11-26 12:38:13 +03:00
let format_lit (fmt : Format.formatter) (l : lit Pos.marked) : unit =
match Pos.unmark l with
| LBool b -> Format.fprintf fmt "%b" b
| LInt i -> Format.fprintf fmt "%s" (Runtime.integer_to_string i)
| LEmptyError -> Format.fprintf fmt ""
2021-03-12 21:37:00 +03:00
| LUnit -> Format.fprintf fmt "()"
2020-12-09 18:45:23 +03:00
| LRat i ->
Format.fprintf fmt "%s"
(Runtime.decimal_to_string ~max_prec_digits:!Utils.Cli.max_prec_digits i)
2021-01-09 23:03:32 +03:00
| LMoney e -> (
match !Utils.Cli.locale_lang with
| En -> Format.fprintf fmt "$%s" (Runtime.money_to_string e)
| Fr -> Format.fprintf fmt "%s €" (Runtime.money_to_string e)
| Pl -> Format.fprintf fmt "%s PLN" (Runtime.money_to_string e))
| LDate d -> Format.fprintf fmt "%s" (Runtime.date_to_string d)
| LDuration d -> Format.fprintf fmt "%s" (Runtime.duration_to_string d)
2020-11-26 12:38:13 +03:00
let format_op_kind (fmt : Format.formatter) (k : op_kind) =
2020-12-10 13:35:56 +03:00
Format.fprintf fmt "%s"
(match k with KInt -> "" | KRat -> "." | KMoney -> "$" | KDate -> "@" | KDuration -> "^")
2020-11-26 12:38:13 +03:00
let format_binop (fmt : Format.formatter) (op : binop Pos.marked) : unit =
format_operator fmt
(match Pos.unmark 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
| Div k -> Format.asprintf "/%a" format_op_kind k
| And -> "&&"
| Or -> "||"
| Xor -> "xor"
| Eq -> "="
| Neq -> "!="
| Lt k -> Format.asprintf "%s%a" "<" format_op_kind k
| Lte k -> Format.asprintf "%s%a" "<=" format_op_kind k
| Gt k -> Format.asprintf "%s%a" ">" format_op_kind k
| Gte k -> Format.asprintf "%s%a" ">=" format_op_kind k
| Concat -> "++"
| Map -> "map"
| Filter -> "filter")
2020-12-28 01:53:02 +03:00
let format_ternop (fmt : Format.formatter) (op : ternop Pos.marked) : unit =
match Pos.unmark op with Fold -> format_keyword fmt "fold"
2020-11-26 12:38:13 +03:00
2020-12-11 12:51:46 +03:00
let format_log_entry (fmt : Format.formatter) (entry : log_entry) : unit =
Format.fprintf fmt "%s"
(match entry with
| VarDef _ -> Utils.Cli.print_with_style [ ANSITerminal.blue ] ""
| BeginCall -> Utils.Cli.print_with_style [ ANSITerminal.yellow ] ""
| EndCall -> Utils.Cli.print_with_style [ ANSITerminal.yellow ] ""
| PosRecordIfTrueBool -> Utils.Cli.print_with_style [ ANSITerminal.green ] "")
2020-12-11 12:51:46 +03:00
2020-11-26 12:38:13 +03:00
let format_unop (fmt : Format.formatter) (op : unop Pos.marked) : unit =
Format.fprintf fmt "%s"
2021-03-23 12:59:43 +03:00
(match Pos.unmark op with
2020-12-11 12:51:46 +03:00
| Minus _ -> "-"
| Not -> "~"
| Log (entry, infos) ->
Format.asprintf "log@[<hov 2>[%a|%a]@]" format_log_entry entry
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
(fun fmt info -> Utils.Uid.MarkedString.format_info fmt info))
2020-12-28 01:53:02 +03:00
infos
| Length -> "length"
| IntToRat -> "int_to_rat"
| GetDay -> "get_day"
| GetMonth -> "get_month"
2021-03-23 12:59:43 +03:00
| GetYear -> "get_year")
2020-11-26 12:38:13 +03:00
2022-01-10 12:28:14 +03:00
let needs_parens (e : expr Pos.marked) : bool =
match Pos.unmark e with EAbs _ | ETuple (_, Some _) -> 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 rec format_expr ?(debug : bool = false) (ctx : Ast.decl_ctx) (fmt : Format.formatter)
(e : expr Pos.marked) : unit =
let format_expr = format_expr ~debug ctx in
let format_with_parens (fmt : Format.formatter) (e : expr Pos.marked) =
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
2020-11-26 12:38:13 +03:00
match Pos.unmark e with
2020-11-27 20:36:38 +03:00
| EVar v -> Format.fprintf fmt "%a" format_var (Pos.unmark v)
2021-01-14 02:17:24 +03:00
| ETuple (es, None) ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" format_punctuation "("
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
2021-01-14 02:17:24 +03:00
(fun fmt e -> Format.fprintf fmt "%a" format_expr e))
es format_punctuation ")"
2021-01-14 02:17:24 +03:00
| ETuple (es, Some s) ->
Format.fprintf fmt "@[<hov 2>%a@ @[<hov 2>%a%a%a@]@]" Ast.StructName.format_t s
format_punctuation "{"
2021-01-14 02:17:24 +03:00
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt (e, struct_field) ->
2021-03-12 21:37:00 +03:00
Format.fprintf fmt "%a%a%a%a %a" format_punctuation "\"" Ast.StructFieldName.format_t
struct_field format_punctuation "\"" format_punctuation ":" format_expr e))
2021-01-28 02:28:28 +03:00
(List.combine es (List.map fst (Ast.StructMap.find s ctx.ctx_structs)))
format_punctuation "}"
2020-12-28 01:53:02 +03:00
| EArray es ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" format_punctuation "["
2020-12-28 01:53:02 +03:00
(Format.pp_print_list
2020-12-30 00:26:10 +03:00
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
2021-01-09 19:44:45 +03:00
(fun fmt e -> Format.fprintf fmt "%a" format_expr e))
es format_punctuation "]"
2021-01-14 02:17:24 +03:00
| ETupleAccess (e1, n, s, _ts) -> (
match s with
| None -> Format.fprintf fmt "%a%a%d" format_expr e1 format_punctuation "." n
2021-01-14 02:17:24 +03:00
| Some s ->
Format.fprintf fmt "%a%a%a%a%a" format_expr e1 format_punctuation "." format_punctuation
"\"" Ast.StructFieldName.format_t
(fst (List.nth (Ast.StructMap.find s ctx.ctx_structs) n))
2021-03-23 12:59:43 +03:00
format_punctuation "\"")
2021-01-14 02:17:24 +03:00
| EInj (e, n, en, _ts) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Ast.EnumConstructor.format_t
2021-01-28 02:28:28 +03:00
(fst (List.nth (Ast.EnumMap.find en ctx.ctx_enums) n))
2021-01-14 02:17:24 +03:00
format_expr e
| EMatch (e, es, e_name) ->
2021-03-12 21:37:00 +03:00
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ @[<hov 2>%a@]@]" format_keyword "match" format_expr e
format_keyword "with"
(Format.pp_print_list
2021-03-12 21:37:00 +03:00
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n| ")
(fun fmt (e, c) ->
2021-03-12 21:37:00 +03:00
Format.fprintf fmt "@[<hov 2>%a%a@ %a@]" Ast.EnumConstructor.format_t c
format_punctuation ":" format_expr e))
2021-01-28 02:28:28 +03:00
(List.combine es (List.map fst (Ast.EnumMap.find e_name ctx.ctx_enums)))
2022-01-10 12:28:14 +03:00
| ELit l ->
Format.fprintf fmt "%s"
(Utils.Cli.print_with_style [ ANSITerminal.yellow ] "%s"
(Format.asprintf "%a" format_lit (Pos.same_pos_as l e)))
2021-04-03 12:49:13 +03:00
| 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
2021-03-12 21:37:00 +03:00
Format.fprintf fmt "%a%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "")
(fun fmt (x, tau, arg) ->
2021-03-12 21:37:00 +03:00
Format.fprintf fmt "@[<hov 2>%a@ @[<hov 2>%a@ %a@ %a@]@ %a@ %a@]@ %a@\n" format_keyword
"let" format_var x format_punctuation ":" (format_typ ctx) tau format_punctuation "="
format_expr arg format_keyword "in"))
xs_tau_arg format_expr body
2021-04-03 12:49:13 +03:00
| EAbs ((binder, _), taus) ->
2020-11-26 12:38:13 +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
2021-03-12 21:37:00 +03:00
Format.fprintf fmt "@[<hov 2>%a @[<hov 2>%a@] %a@ %a@]" format_punctuation "λ"
2020-11-26 12:38:13 +03:00
(Format.pp_print_list
2020-12-30 14:02:09 +03:00
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
2020-12-30 00:26:10 +03:00
(fun fmt (x, tau) ->
2021-03-12 21:37:00 +03:00
Format.fprintf fmt "%a%a%a %a%a" format_punctuation "(" format_var x format_punctuation
":" (format_typ ctx) tau format_punctuation ")"))
xs_tau format_punctuation "" format_expr body
2021-01-10 20:11:46 +03:00
| 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_with_parens
arg1 format_with_parens arg2
2020-11-26 12:38:13 +03:00
| EApp ((EOp (Binop op), _), [ arg1; arg2 ]) ->
2020-12-30 00:26:10 +03:00
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" format_with_parens arg1 format_binop
(op, Pos.no_pos) format_with_parens arg2
| EApp ((EOp (Unop (Log _)), _), [ arg1 ]) when not debug -> format_expr fmt arg1
2020-11-26 12:38:13 +03:00
| EApp ((EOp (Unop op), _), [ arg1 ]) ->
2020-12-30 00:26:10 +03:00
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_unop (op, Pos.no_pos) format_with_parens arg1
2020-11-26 12:38:13 +03:00
| EApp (f, args) ->
2020-12-30 00:26:10 +03:00
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_expr f
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") format_with_parens)
2020-11-26 12:38:13 +03:00
args
| EIfThenElse (e1, e2, e3) ->
2021-03-12 21:37:00 +03:00
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
2020-12-28 01:53:02 +03:00
| EOp (Ternop op) -> Format.fprintf fmt "%a" format_ternop (op, Pos.no_pos)
2020-11-26 12:38:13 +03:00
| EOp (Binop op) -> Format.fprintf fmt "%a" format_binop (op, Pos.no_pos)
| EOp (Unop op) -> Format.fprintf fmt "%a" format_unop (op, Pos.no_pos)
| EDefault (exceptions, just, cons) ->
if List.length exceptions = 0 then
2021-03-12 21:37:00 +03:00
Format.fprintf fmt "@[<hov 2>%a%a@ %a@ %a@,%a@]" format_punctuation "" format_expr just
format_punctuation "" format_expr cons format_punctuation ""
else
2021-03-12 21:37:00 +03:00
Format.fprintf fmt "@[<hov 2>%a%a@ %a@ %a@ %a@ %a@,%a@]" format_punctuation ""
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " format_punctuation ",")
format_expr)
2021-08-19 12:35:56 +03:00
exceptions format_punctuation "|" format_expr just format_punctuation "" format_expr cons
format_punctuation ""
| ErrorOnEmpty e' -> Format.fprintf fmt "error_empty@ %a" format_with_parens e'
| EAssert e' ->
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" format_keyword "assert" format_punctuation "("
format_expr e' format_punctuation ")"
2021-12-10 00:59:39 +03:00
let format_scope ?(debug : bool = false) (ctx : decl_ctx) (fmt : Format.formatter)
((n, s) : Ast.ScopeName.t * scope_body) =
Format.fprintf fmt "@[<hov 2>let %a =@ %a@]" Ast.ScopeName.format_t n (format_expr ctx ~debug)
(Bindlib.unbox (Ast.build_whole_scope_expr ctx s (Pos.get_position (Ast.ScopeName.get_info n))))