2020-11-25 18:51:19 +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. *)
|
|
|
|
|
|
|
|
module Pos = Utils.Pos
|
2020-11-26 12:38:13 +03:00
|
|
|
open Ast
|
2020-11-25 18:51:19 +03:00
|
|
|
|
2020-11-26 17:48:26 +03:00
|
|
|
let typ_needs_parens (e : typ Pos.marked) : bool =
|
|
|
|
match Pos.unmark e with TArrow _ -> true | _ -> false
|
|
|
|
|
2020-12-10 13:35:56 +03:00
|
|
|
let format_tlit (fmt : Format.formatter) (l : typ_lit) : unit =
|
|
|
|
match l with
|
|
|
|
| TUnit -> Format.fprintf fmt "unit"
|
|
|
|
| TBool -> Format.fprintf fmt "boolean"
|
|
|
|
| TInt -> Format.fprintf fmt "integer"
|
|
|
|
| TRat -> Format.fprintf fmt "decimal"
|
|
|
|
| TMoney -> Format.fprintf fmt "money"
|
|
|
|
| TDuration -> Format.fprintf fmt "duration"
|
|
|
|
| TDate -> Format.fprintf fmt "date"
|
|
|
|
|
2020-11-26 12:38:13 +03:00
|
|
|
let rec format_typ (fmt : Format.formatter) (typ : typ Pos.marked) : unit =
|
2020-11-26 17:48:26 +03:00
|
|
|
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
|
2020-11-25 18:51:19 +03:00
|
|
|
match Pos.unmark typ with
|
2020-12-10 13:35:56 +03:00
|
|
|
| TLit l -> Format.fprintf fmt "%a" format_tlit l
|
2020-11-25 18:51:19 +03:00
|
|
|
| TTuple ts ->
|
|
|
|
Format.fprintf fmt "(%a)"
|
2020-11-27 14:18:49 +03:00
|
|
|
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt " *@ ") format_typ)
|
2020-11-25 18:51:19 +03:00
|
|
|
ts
|
2020-12-03 22:11:41 +03:00
|
|
|
| TEnum ts ->
|
|
|
|
Format.fprintf fmt "(%a)"
|
|
|
|
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt " +@ ") format_typ)
|
|
|
|
ts
|
2020-11-27 18:27:10 +03:00
|
|
|
| TArrow (t1, t2) ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a →@ %a@]" format_typ_with_parens t1 format_typ t2
|
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
|
2020-12-09 18:45:23 +03:00
|
|
|
| LInt i -> Format.fprintf fmt "%s" (Z.to_string i)
|
2020-11-26 12:38:13 +03:00
|
|
|
| LEmptyError -> Format.fprintf fmt "∅"
|
2020-11-26 15:38:42 +03:00
|
|
|
| LUnit -> Format.fprintf fmt "()"
|
2020-12-09 18:45:23 +03:00
|
|
|
| LRat i ->
|
|
|
|
let sign = Q.sign i in
|
|
|
|
let n = Z.abs (Q.num i) in
|
|
|
|
let d = Z.abs (Q.den i) in
|
|
|
|
let int_part = Z.ediv n d in
|
|
|
|
let n = ref (Z.erem n d) in
|
|
|
|
let digits = ref [] in
|
|
|
|
let leading_zeroes (digits : Z.t list) : int =
|
|
|
|
match
|
|
|
|
List.fold_right
|
|
|
|
(fun digit num_leading_zeroes ->
|
|
|
|
match num_leading_zeroes with
|
|
|
|
| `End _ -> num_leading_zeroes
|
|
|
|
| `Begin i -> if Z.(digit = zero) then `Begin (i + 1) else `End i)
|
|
|
|
digits (`Begin 0)
|
|
|
|
with
|
|
|
|
| `End i -> i
|
|
|
|
| `Begin i -> i
|
|
|
|
in
|
|
|
|
while
|
|
|
|
!n <> Z.zero && List.length !digits - leading_zeroes !digits < !Utils.Cli.max_prec_digits
|
|
|
|
do
|
|
|
|
n := Z.mul !n (Z.of_int 10);
|
|
|
|
digits := Z.ediv !n d :: !digits;
|
|
|
|
n := Z.erem !n d
|
|
|
|
done;
|
|
|
|
Format.fprintf fmt "%s%a.%a%s"
|
|
|
|
(if sign < 0 then "-" else "")
|
|
|
|
Z.pp_print int_part
|
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun _fmt () -> ())
|
|
|
|
(fun fmt digit -> Format.fprintf fmt "%a" Z.pp_print digit))
|
|
|
|
(List.rev !digits)
|
|
|
|
( if List.length !digits - leading_zeroes !digits = !Utils.Cli.max_prec_digits then "…"
|
|
|
|
else "" )
|
2020-12-09 16:51:22 +03:00
|
|
|
| LMoney e -> Format.fprintf fmt "$%.2f" Q.(to_float (of_bigint e / of_int 100))
|
2020-12-10 13:35:56 +03:00
|
|
|
| LDate d ->
|
|
|
|
Format.fprintf fmt "%s"
|
|
|
|
(ODate.Unix.To.string (Option.get (ODate.Unix.To.generate_printer "%Y-%m-%d")) d)
|
2020-12-10 16:00:00 +03:00
|
|
|
| LDuration d -> Format.fprintf fmt "%a days" Z.pp_print d
|
2020-11-26 12:38:13 +03:00
|
|
|
|
2020-12-09 20:14:52 +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-12-09 20:14:52 +03:00
|
|
|
|
2020-11-26 12:38:13 +03:00
|
|
|
let format_binop (fmt : Format.formatter) (op : binop Pos.marked) : unit =
|
2020-12-09 20:14:52 +03:00
|
|
|
match Pos.unmark op with
|
|
|
|
| Add k -> Format.fprintf fmt "+%a" format_op_kind k
|
|
|
|
| Sub k -> Format.fprintf fmt "-%a" format_op_kind k
|
|
|
|
| Mult k -> Format.fprintf fmt "*%a" format_op_kind k
|
|
|
|
| Div k -> Format.fprintf fmt "/%a" format_op_kind k
|
|
|
|
| And -> Format.fprintf fmt "%s" "&&"
|
|
|
|
| Or -> Format.fprintf fmt "%s" "||"
|
|
|
|
| Eq -> Format.fprintf fmt "%s" "=="
|
|
|
|
| Neq -> Format.fprintf fmt "%s" "!="
|
2020-12-10 13:51:50 +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
|
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 -> "Defining variable"
|
|
|
|
| BeginCall -> "Calling subscope"
|
|
|
|
| EndCall -> "Returned from subscope" )
|
|
|
|
|
2020-11-26 12:38:13 +03:00
|
|
|
let format_unop (fmt : Format.formatter) (op : unop Pos.marked) : unit =
|
2020-12-09 13:23:03 +03:00
|
|
|
Format.fprintf fmt "%s"
|
2020-12-11 12:51:46 +03:00
|
|
|
( match Pos.unmark op with
|
|
|
|
| Minus _ -> "-"
|
|
|
|
| Not -> "~"
|
|
|
|
| ErrorOnEmpty -> "error_empty"
|
|
|
|
| Log (entry, infos) ->
|
|
|
|
Format.asprintf "log@[<hov 2>[%a|%a]@]" format_log_entry entry
|
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
|
|
|
|
(fun fmt info -> Utils.Uid.MarkedString.format_info fmt info))
|
|
|
|
infos )
|
2020-11-26 12:38:13 +03:00
|
|
|
|
2020-11-26 15:38:42 +03:00
|
|
|
let needs_parens (e : expr Pos.marked) : bool =
|
2020-12-11 12:51:46 +03:00
|
|
|
match Pos.unmark e with EAbs _ | EApp _ -> true | _ -> false
|
2020-11-26 15:38:42 +03:00
|
|
|
|
|
|
|
let format_var (fmt : Format.formatter) (v : Var.t) : unit =
|
2020-11-27 13:37:21 +03:00
|
|
|
Format.fprintf fmt "%s" (Bindlib.name_of v)
|
2020-11-26 15:38:42 +03:00
|
|
|
|
2020-11-26 12:38:13 +03:00
|
|
|
let rec format_expr (fmt : Format.formatter) (e : expr Pos.marked) : unit =
|
2020-11-26 15:38:42 +03:00
|
|
|
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
|
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)
|
2020-11-26 12:38:13 +03:00
|
|
|
| ETuple es ->
|
|
|
|
Format.fprintf fmt "(%a)"
|
2020-12-05 20:12:53 +03:00
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt ",")
|
|
|
|
(fun fmt (e, struct_field) ->
|
|
|
|
match struct_field with
|
|
|
|
| Some struct_field ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>\"%a\":@ %a@]" Uid.MarkedString.format_info
|
|
|
|
struct_field format_expr e
|
|
|
|
| None -> Format.fprintf fmt "@[%a@]" format_expr e))
|
2020-11-26 12:38:13 +03:00
|
|
|
es
|
2020-12-05 20:12:53 +03:00
|
|
|
| ETupleAccess (e1, n, i) -> (
|
|
|
|
match i with
|
|
|
|
| None -> Format.fprintf fmt "%a.%d" format_expr e1 n
|
|
|
|
| Some i -> Format.fprintf fmt "%a.\"%a\"" format_expr e1 Uid.MarkedString.format_info i )
|
|
|
|
| EInj (e, _n, i, _ts) -> Format.fprintf fmt "%a %a" Uid.MarkedString.format_info i format_expr e
|
2020-12-03 22:11:41 +03:00
|
|
|
| EMatch (e, es) ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>match %a with %a@]" format_expr e
|
2020-12-05 20:12:53 +03:00
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt " |@ ")
|
|
|
|
(fun fmt (e, c) ->
|
|
|
|
Format.fprintf fmt "%a %a" Uid.MarkedString.format_info c format_expr e))
|
2020-12-03 22:11:41 +03:00
|
|
|
es
|
2020-11-26 12:38:13 +03:00
|
|
|
| ELit l -> Format.fprintf fmt "%a" format_lit (Pos.same_pos_as l e)
|
2020-11-26 15:38:42 +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
|
|
|
|
Format.fprintf fmt "@[%a%a@]"
|
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt " ")
|
|
|
|
(fun fmt (x, tau, arg) ->
|
|
|
|
Format.fprintf fmt "@[@[<hov 2>let@ %a@ :@ %a@ =@ %a@]@ in@\n@]" format_var x
|
|
|
|
format_typ tau format_expr arg))
|
|
|
|
xs_tau_arg format_expr body
|
2020-11-26 12:38:13 +03:00
|
|
|
| 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
|
2020-11-26 15:38:42 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>λ@ %a@ →@ %a@]"
|
2020-11-26 12:38:13 +03:00
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt " ")
|
2020-11-26 15:38:42 +03:00
|
|
|
(fun fmt (x, tau) -> Format.fprintf fmt "@[(%a:@ %a)@]" format_var x format_typ tau))
|
2020-11-26 12:38:13 +03:00
|
|
|
xs_tau format_expr body
|
|
|
|
| EApp ((EOp (Binop op), _), [ arg1; arg2 ]) ->
|
2020-11-26 15:38:42 +03:00
|
|
|
Format.fprintf fmt "@[%a@ %a@ %a@]" format_with_parens arg1 format_binop (op, Pos.no_pos)
|
|
|
|
format_with_parens arg2
|
2020-11-26 12:38:13 +03:00
|
|
|
| EApp ((EOp (Unop op), _), [ arg1 ]) ->
|
2020-11-26 15:38:42 +03:00
|
|
|
Format.fprintf fmt "@[%a@ %a@]" format_unop (op, Pos.no_pos) format_with_parens arg1
|
2020-11-26 12:38:13 +03:00
|
|
|
| EApp (f, args) ->
|
2020-11-26 15:38:42 +03:00
|
|
|
Format.fprintf fmt "@[%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) ->
|
2020-11-26 15:38:42 +03:00
|
|
|
Format.fprintf fmt "if@ @[<hov 2>%a@]@ then@ @[<hov 2>%a@]@ else@ @[<hov 2>%a@]" format_expr
|
|
|
|
e1 format_expr e2 format_expr e3
|
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)
|
2020-12-18 17:59:15 +03:00
|
|
|
| EDefault (exceptions, just, cons) ->
|
|
|
|
if List.length exceptions = 0 then
|
2020-11-26 15:38:42 +03:00
|
|
|
Format.fprintf fmt "@[⟨%a ⊢ %a⟩@]" format_expr just format_expr cons
|
|
|
|
else
|
2020-12-18 17:59:15 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>⟨%a@ |@ %a ⊢ %a ⟩@]"
|
2020-11-26 15:38:42 +03:00
|
|
|
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") format_expr)
|
2020-12-18 17:59:15 +03:00
|
|
|
exceptions format_expr just format_expr cons
|
2020-12-10 20:11:43 +03:00
|
|
|
| EAssert e' -> Format.fprintf fmt "@[<hov 2>assert@ (%a)@]" format_expr e'
|