2022-08-17 17:14:14 +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. *)
|
|
|
|
|
2022-11-21 12:46:17 +03:00
|
|
|
open Catala_utils
|
2022-08-22 19:53:30 +03:00
|
|
|
open Definitions
|
2022-08-17 17:14:14 +03:00
|
|
|
|
2022-08-25 18:29:00 +03:00
|
|
|
let typ_needs_parens (ty : typ) : bool =
|
2022-08-25 13:09:51 +03:00
|
|
|
match Marked.unmark ty with TArrow _ | TArray _ -> true | _ -> false
|
2022-08-17 17:14:14 +03:00
|
|
|
|
|
|
|
let uid_list (fmt : Format.formatter) (infos : Uid.MarkedString.info list) :
|
|
|
|
unit =
|
|
|
|
Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.pp_print_char fmt '.')
|
|
|
|
(fun fmt info ->
|
2022-11-21 12:46:17 +03:00
|
|
|
Cli.format_with_style
|
2022-11-24 20:00:45 +03:00
|
|
|
(if String.begins_with_uppercase (Marked.unmark info) then
|
|
|
|
[ANSITerminal.red]
|
2022-08-17 17:14:14 +03:00
|
|
|
else [])
|
|
|
|
fmt
|
2022-11-21 12:46:17 +03:00
|
|
|
(Uid.MarkedString.to_string info))
|
2022-08-17 17:14:14 +03:00
|
|
|
fmt infos
|
|
|
|
|
|
|
|
let keyword (fmt : Format.formatter) (s : string) : unit =
|
2022-11-21 12:46:17 +03:00
|
|
|
Cli.format_with_style [ANSITerminal.red] fmt s
|
2022-08-17 17:14:14 +03:00
|
|
|
|
|
|
|
let base_type (fmt : Format.formatter) (s : string) : unit =
|
2022-11-21 12:46:17 +03:00
|
|
|
Cli.format_with_style [ANSITerminal.yellow] fmt s
|
2022-08-17 17:14:14 +03:00
|
|
|
|
|
|
|
let punctuation (fmt : Format.formatter) (s : string) : unit =
|
2022-11-21 12:46:17 +03:00
|
|
|
Cli.format_with_style [ANSITerminal.cyan] fmt s
|
2022-08-17 17:14:14 +03:00
|
|
|
|
|
|
|
let operator (fmt : Format.formatter) (s : string) : unit =
|
2022-11-21 12:46:17 +03:00
|
|
|
Cli.format_with_style [ANSITerminal.green] fmt s
|
2022-08-17 17:14:14 +03:00
|
|
|
|
|
|
|
let lit_style (fmt : Format.formatter) (s : string) : unit =
|
2022-11-21 12:46:17 +03:00
|
|
|
Cli.format_with_style [ANSITerminal.yellow] fmt s
|
2022-08-17 17:14:14 +03:00
|
|
|
|
|
|
|
let tlit (fmt : Format.formatter) (l : typ_lit) : unit =
|
|
|
|
base_type fmt
|
|
|
|
(match l with
|
|
|
|
| TUnit -> "unit"
|
|
|
|
| TBool -> "bool"
|
|
|
|
| TInt -> "integer"
|
|
|
|
| TRat -> "decimal"
|
|
|
|
| TMoney -> "money"
|
|
|
|
| TDuration -> "duration"
|
|
|
|
| TDate -> "date")
|
|
|
|
|
2022-08-25 13:09:51 +03:00
|
|
|
let location (type a) (fmt : Format.formatter) (l : a glocation) : unit =
|
2022-08-17 19:14:30 +03:00
|
|
|
match l with
|
2022-10-12 14:45:04 +03:00
|
|
|
| DesugaredScopeVar (v, _st) -> ScopeVar.format_t fmt (Marked.unmark v)
|
|
|
|
| ScopelangScopeVar v -> ScopeVar.format_t fmt (Marked.unmark v)
|
2022-08-17 19:14:30 +03:00
|
|
|
| SubScopeVar (_, subindex, subvar) ->
|
|
|
|
Format.fprintf fmt "%a.%a" SubScopeName.format_t (Marked.unmark subindex)
|
|
|
|
ScopeVar.format_t (Marked.unmark subvar)
|
|
|
|
|
2022-08-17 17:14:14 +03:00
|
|
|
let enum_constructor (fmt : Format.formatter) (c : EnumConstructor.t) : unit =
|
2022-11-21 12:46:17 +03:00
|
|
|
Cli.format_with_style [ANSITerminal.magenta] fmt
|
2022-08-17 17:14:14 +03:00
|
|
|
(Format.asprintf "%a" EnumConstructor.format_t c)
|
|
|
|
|
2022-09-30 17:37:43 +03:00
|
|
|
let rec typ (ctx : decl_ctx option) (fmt : Format.formatter) (ty : typ) : unit =
|
2022-08-17 17:14:14 +03:00
|
|
|
let typ = typ ctx in
|
2022-08-25 18:29:00 +03:00
|
|
|
let typ_with_parens (fmt : Format.formatter) (t : typ) =
|
2022-10-12 14:45:04 +03:00
|
|
|
if typ_needs_parens t then Format.fprintf fmt "(%a)" typ t else typ fmt t
|
2022-08-17 17:14:14 +03:00
|
|
|
in
|
2022-08-25 13:09:51 +03:00
|
|
|
match Marked.unmark ty with
|
2022-08-17 17:14:14 +03:00
|
|
|
| TLit l -> tlit fmt l
|
2022-08-23 16:23:52 +03:00
|
|
|
| TTuple ts ->
|
2022-08-17 17:14:14 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>(%a)@]"
|
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ %a@ " operator "*")
|
2022-10-12 14:45:04 +03:00
|
|
|
typ)
|
2022-08-25 13:09:51 +03:00
|
|
|
ts
|
2022-09-30 17:37:43 +03:00
|
|
|
| TStruct s -> (
|
|
|
|
match ctx with
|
|
|
|
| None -> Format.fprintf fmt "@[<hov 2>%a@]" StructName.format_t s
|
|
|
|
| Some ctx ->
|
2022-11-03 17:18:51 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" StructName.format_t s
|
|
|
|
punctuation "{"
|
2022-09-30 17:37:43 +03:00
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " punctuation ";")
|
|
|
|
(fun fmt (field, mty) ->
|
|
|
|
Format.fprintf fmt "%a%a%a%a@ %a" punctuation "\""
|
2022-11-21 12:12:45 +03:00
|
|
|
StructField.format_t field punctuation "\"" punctuation ":" typ
|
|
|
|
mty))
|
|
|
|
(StructField.Map.bindings (StructName.Map.find s ctx.ctx_structs))
|
2022-09-30 17:37:43 +03:00
|
|
|
punctuation "}")
|
|
|
|
| TEnum e -> (
|
|
|
|
match ctx with
|
|
|
|
| None -> Format.fprintf fmt "@[<hov 2>%a@]" EnumName.format_t e
|
|
|
|
| Some ctx ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a%a%a%a@]" EnumName.format_t e punctuation
|
|
|
|
"["
|
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ %a@ " punctuation "|")
|
|
|
|
(fun fmt (case, mty) ->
|
|
|
|
Format.fprintf fmt "%a%a@ %a" enum_constructor case punctuation ":"
|
|
|
|
typ mty))
|
2022-11-21 12:12:45 +03:00
|
|
|
(EnumConstructor.Map.bindings (EnumName.Map.find e ctx.ctx_enums))
|
2022-09-30 17:37:43 +03:00
|
|
|
punctuation "]")
|
2022-08-25 13:09:51 +03:00
|
|
|
| TOption t -> Format.fprintf fmt "@[<hov 2>%a@ %a@]" base_type "option" typ t
|
2022-08-17 17:14:14 +03:00
|
|
|
| TArrow (t1, t2) ->
|
2022-08-25 13:09:51 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" typ_with_parens t1 operator "→"
|
|
|
|
typ t2
|
2022-09-26 17:05:57 +03:00
|
|
|
| TArray t1 ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@]" base_type "collection" typ t1
|
2022-08-17 17:14:14 +03:00
|
|
|
| TAny -> base_type fmt "any"
|
|
|
|
|
|
|
|
let lit (type a) (fmt : Format.formatter) (l : a glit) : unit =
|
|
|
|
match l with
|
|
|
|
| LBool b -> lit_style fmt (string_of_bool b)
|
|
|
|
| LInt i -> lit_style fmt (Runtime.integer_to_string i)
|
|
|
|
| LEmptyError -> lit_style fmt "∅ "
|
|
|
|
| LUnit -> lit_style fmt "()"
|
|
|
|
| LRat i ->
|
|
|
|
lit_style fmt
|
2022-11-21 12:46:17 +03:00
|
|
|
(Runtime.decimal_to_string ~max_prec_digits:!Cli.max_prec_digits i)
|
2022-08-17 17:14:14 +03:00
|
|
|
| LMoney e -> (
|
2022-11-21 12:46:17 +03:00
|
|
|
match !Cli.locale_lang with
|
2022-08-17 17:14:14 +03:00
|
|
|
| En -> lit_style fmt (Format.asprintf "$%s" (Runtime.money_to_string e))
|
|
|
|
| Fr -> lit_style fmt (Format.asprintf "%s €" (Runtime.money_to_string e))
|
|
|
|
| Pl -> lit_style fmt (Format.asprintf "%s PLN" (Runtime.money_to_string e))
|
|
|
|
)
|
|
|
|
| LDate d -> lit_style fmt (Runtime.date_to_string d)
|
|
|
|
| LDuration d -> lit_style fmt (Runtime.duration_to_string d)
|
|
|
|
|
2022-11-22 22:57:59 +03:00
|
|
|
let op_kind (fmt : Format.formatter) (k : 'a op_kind) =
|
2022-08-17 17:14:14 +03:00
|
|
|
Format.fprintf fmt "%s"
|
|
|
|
(match k with
|
|
|
|
| KInt -> ""
|
|
|
|
| KRat -> "."
|
|
|
|
| KMoney -> "$"
|
|
|
|
| KDate -> "@"
|
|
|
|
| KDuration -> "^")
|
|
|
|
|
2022-11-22 22:57:59 +03:00
|
|
|
let binop (fmt : Format.formatter) (op : 'a binop) : unit =
|
2022-08-17 17:14:14 +03:00
|
|
|
operator fmt
|
|
|
|
(match op with
|
|
|
|
| Add k -> Format.asprintf "+%a" op_kind k
|
|
|
|
| Sub k -> Format.asprintf "-%a" op_kind k
|
|
|
|
| Mult k -> Format.asprintf "*%a" op_kind k
|
|
|
|
| Div k -> Format.asprintf "/%a" op_kind k
|
|
|
|
| And -> "&&"
|
|
|
|
| Or -> "||"
|
|
|
|
| Xor -> "xor"
|
|
|
|
| Eq -> "="
|
|
|
|
| Neq -> "!="
|
|
|
|
| Lt k -> Format.asprintf "%s%a" "<" op_kind k
|
|
|
|
| Lte k -> Format.asprintf "%s%a" "<=" op_kind k
|
|
|
|
| Gt k -> Format.asprintf "%s%a" ">" op_kind k
|
|
|
|
| Gte k -> Format.asprintf "%s%a" ">=" op_kind k
|
|
|
|
| Concat -> "++"
|
|
|
|
| Map -> "map"
|
|
|
|
| Filter -> "filter")
|
|
|
|
|
|
|
|
let ternop (fmt : Format.formatter) (op : ternop) : unit =
|
|
|
|
match op with Fold -> keyword fmt "fold"
|
|
|
|
|
|
|
|
let log_entry (fmt : Format.formatter) (entry : log_entry) : unit =
|
|
|
|
Format.fprintf fmt "@<2>%a"
|
|
|
|
(fun fmt -> function
|
2022-11-21 12:46:17 +03:00
|
|
|
| VarDef _ -> Cli.format_with_style [ANSITerminal.blue] fmt "≔ "
|
|
|
|
| BeginCall -> Cli.format_with_style [ANSITerminal.yellow] fmt "→ "
|
|
|
|
| EndCall -> Cli.format_with_style [ANSITerminal.yellow] fmt "← "
|
2022-08-17 17:14:14 +03:00
|
|
|
| PosRecordIfTrueBool ->
|
2022-11-21 12:46:17 +03:00
|
|
|
Cli.format_with_style [ANSITerminal.green] fmt "☛ ")
|
2022-08-17 17:14:14 +03:00
|
|
|
entry
|
|
|
|
|
2022-11-22 22:57:59 +03:00
|
|
|
let unop (fmt : Format.formatter) (op : 'a unop) : unit =
|
2022-08-17 17:14:14 +03:00
|
|
|
match op with
|
|
|
|
| Minus _ -> Format.pp_print_string fmt "-"
|
|
|
|
| Not -> Format.pp_print_string fmt "~"
|
|
|
|
| Log (entry, infos) ->
|
|
|
|
Format.fprintf fmt "log@[<hov 2>[%a|%a]@]" log_entry entry
|
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
|
2022-11-21 12:46:17 +03:00
|
|
|
(fun fmt info -> Uid.MarkedString.format fmt info))
|
2022-08-17 17:14:14 +03:00
|
|
|
infos
|
|
|
|
| Length -> Format.pp_print_string fmt "length"
|
|
|
|
| IntToRat -> Format.pp_print_string fmt "int_to_rat"
|
|
|
|
| MoneyToRat -> Format.pp_print_string fmt "money_to_rat"
|
|
|
|
| RatToMoney -> Format.pp_print_string fmt "rat_to_money"
|
|
|
|
| GetDay -> Format.pp_print_string fmt "get_day"
|
|
|
|
| GetMonth -> Format.pp_print_string fmt "get_month"
|
|
|
|
| GetYear -> Format.pp_print_string fmt "get_year"
|
|
|
|
| FirstDayOfMonth -> Format.pp_print_string fmt "first_day_of_month"
|
|
|
|
| LastDayOfMonth -> Format.pp_print_string fmt "last_day_of_month"
|
|
|
|
| RoundMoney -> Format.pp_print_string fmt "round_money"
|
|
|
|
| RoundDecimal -> Format.pp_print_string fmt "round_decimal"
|
|
|
|
|
|
|
|
let except (fmt : Format.formatter) (exn : except) : unit =
|
|
|
|
operator fmt
|
|
|
|
(match exn with
|
|
|
|
| EmptyError -> "EmptyError"
|
|
|
|
| ConflictError -> "ConflictError"
|
|
|
|
| Crash -> "Crash"
|
|
|
|
| NoValueProvided -> "NoValueProvided")
|
|
|
|
|
2022-10-12 14:45:04 +03:00
|
|
|
let var_debug fmt v =
|
2022-08-17 17:14:14 +03:00
|
|
|
Format.fprintf fmt "%s_%d" (Bindlib.name_of v) (Bindlib.uid_of v)
|
|
|
|
|
2022-10-12 14:45:04 +03:00
|
|
|
let var fmt v = Format.pp_print_string fmt (Bindlib.name_of v)
|
|
|
|
|
2022-08-25 17:31:32 +03:00
|
|
|
let needs_parens (type a) (e : (a, _) gexpr) : bool =
|
2022-11-17 19:13:35 +03:00
|
|
|
match Marked.unmark e with EAbs _ | EStruct _ -> true | _ -> false
|
2022-08-25 13:09:51 +03:00
|
|
|
|
2022-10-12 14:45:04 +03:00
|
|
|
let rec expr_aux :
|
2022-09-30 17:37:43 +03:00
|
|
|
type a.
|
2022-10-12 14:45:04 +03:00
|
|
|
?debug:bool ->
|
|
|
|
decl_ctx option ->
|
|
|
|
Bindlib.ctxt ->
|
|
|
|
Format.formatter ->
|
|
|
|
(a, 't) gexpr ->
|
|
|
|
unit =
|
|
|
|
fun ?(debug = false) ctx bnd_ctx fmt e ->
|
|
|
|
let exprb bnd_ctx e = expr_aux ~debug ctx bnd_ctx e in
|
|
|
|
let expr e = exprb bnd_ctx e in
|
2022-11-17 19:13:35 +03:00
|
|
|
let var = if debug then var_debug else var in
|
2022-09-30 17:37:43 +03:00
|
|
|
let with_parens fmt e =
|
|
|
|
if needs_parens e then (
|
|
|
|
punctuation fmt "(";
|
|
|
|
expr fmt e;
|
|
|
|
punctuation fmt ")")
|
|
|
|
else expr fmt e
|
|
|
|
in
|
|
|
|
match Marked.unmark e with
|
2022-11-17 19:13:35 +03:00
|
|
|
| EVar v -> var fmt v
|
|
|
|
| ETuple es ->
|
2022-09-30 17:37:43 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a%a%a@]" punctuation "("
|
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
2022-10-12 14:45:04 +03:00
|
|
|
(fun fmt e -> expr fmt e))
|
2022-09-30 17:37:43 +03:00
|
|
|
es punctuation ")"
|
|
|
|
| EArray es ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a%a%a@]" punctuation "["
|
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
|
2022-10-12 14:45:04 +03:00
|
|
|
(fun fmt e -> expr fmt e))
|
2022-09-30 17:37:43 +03:00
|
|
|
es punctuation "]"
|
2022-11-17 19:13:35 +03:00
|
|
|
| ETupleAccess { e; index; _ } ->
|
|
|
|
expr fmt e;
|
|
|
|
punctuation fmt ".";
|
|
|
|
Format.pp_print_int fmt index
|
2022-09-30 17:37:43 +03:00
|
|
|
| ELit l -> lit fmt l
|
2022-11-17 19:13:35 +03:00
|
|
|
| EApp { f = EAbs { binder; tys }, _; args } ->
|
2022-10-12 14:45:04 +03:00
|
|
|
let xs, body, bnd_ctx = Bindlib.unmbind_in bnd_ctx binder in
|
|
|
|
let expr = exprb bnd_ctx in
|
2022-11-17 19:13:35 +03:00
|
|
|
let xs_tau = List.mapi (fun i tau -> xs.(i), tau) tys in
|
2022-09-30 17:37:43 +03:00
|
|
|
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>%a@ %a@ %a@ %a@ %a@ %a@ %a@]@\n" keyword
|
|
|
|
"let" var x punctuation ":" (typ ctx) tau punctuation "=" expr arg
|
|
|
|
keyword "in"))
|
|
|
|
xs_tau_arg expr body
|
2022-11-17 19:13:35 +03:00
|
|
|
| EAbs { binder; tys } ->
|
2022-10-12 14:45:04 +03:00
|
|
|
let xs, body, bnd_ctx = Bindlib.unmbind_in bnd_ctx binder in
|
|
|
|
let expr = exprb bnd_ctx in
|
2022-11-17 19:13:35 +03:00
|
|
|
let xs_tau = List.mapi (fun i tau -> xs.(i), tau) tys in
|
2022-09-30 17:37:43 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a @[<hov 2>%a@] %a@ %a@]" punctuation "λ"
|
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
|
|
|
|
(fun fmt (x, tau) ->
|
|
|
|
Format.fprintf fmt "%a%a%a %a%a" punctuation "(" var x punctuation
|
|
|
|
":" (typ ctx) tau punctuation ")"))
|
|
|
|
xs_tau punctuation "→" expr body
|
2022-11-17 19:13:35 +03:00
|
|
|
| EApp { f = EOp (Binop ((Map | Filter) as op)), _; args = [arg1; arg2] } ->
|
2022-09-30 17:37:43 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" binop op with_parens arg1
|
|
|
|
with_parens arg2
|
2022-11-17 19:13:35 +03:00
|
|
|
| EApp { f = EOp (Binop op), _; args = [arg1; arg2] } ->
|
2022-09-30 17:37:43 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" with_parens arg1 binop op
|
|
|
|
with_parens arg2
|
2022-11-17 19:13:35 +03:00
|
|
|
| EApp { f = EOp (Unop (Log _)), _; args = [arg1] } when not debug ->
|
|
|
|
expr fmt arg1
|
|
|
|
| EApp { f = EOp (Unop op), _; args = [arg1] } ->
|
2022-09-30 17:37:43 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@]" unop op with_parens arg1
|
2022-11-17 19:13:35 +03:00
|
|
|
| EApp { f; args } ->
|
2022-09-30 17:37:43 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@]" expr f
|
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
|
|
|
|
with_parens)
|
|
|
|
args
|
2022-11-17 19:13:35 +03:00
|
|
|
| EIfThenElse { cond; etrue; efalse } ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@]" keyword "if" expr
|
|
|
|
cond keyword "then" expr etrue keyword "else" expr efalse
|
2022-10-12 14:45:04 +03:00
|
|
|
| EOp (Ternop op) -> ternop fmt op
|
|
|
|
| EOp (Binop op) -> binop fmt op
|
|
|
|
| EOp (Unop op) -> unop fmt op
|
2022-11-17 19:13:35 +03:00
|
|
|
| EDefault { excepts; just; cons } ->
|
|
|
|
if List.length excepts = 0 then
|
2022-09-30 17:37:43 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a%a@ %a@ %a%a@]" punctuation "⟨" expr just
|
|
|
|
punctuation "⊢" expr cons punctuation "⟩"
|
|
|
|
else
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a%a@ %a@ %a@ %a@ %a%a@]" punctuation "⟨"
|
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " punctuation ",")
|
|
|
|
expr)
|
2022-11-17 19:13:35 +03:00
|
|
|
excepts punctuation "|" expr just punctuation "⊢" expr cons punctuation
|
|
|
|
"⟩"
|
|
|
|
| EErrorOnEmpty e' ->
|
2022-09-30 17:37:43 +03:00
|
|
|
Format.fprintf fmt "%a@ %a" operator "error_empty" with_parens e'
|
|
|
|
| EAssert e' ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" keyword "assert" punctuation "("
|
|
|
|
expr e' punctuation ")"
|
2022-11-17 19:13:35 +03:00
|
|
|
| ECatch { body; exn; handler } ->
|
2022-09-30 17:37:43 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a ->@ %a@]" keyword "try"
|
2022-11-17 19:13:35 +03:00
|
|
|
with_parens body keyword "with" except exn with_parens handler
|
2022-09-30 17:37:43 +03:00
|
|
|
| ERaise exn ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@]" keyword "raise" except exn
|
|
|
|
| ELocation loc -> location fmt loc
|
2022-11-22 22:57:59 +03:00
|
|
|
| EDStructAccess { e; field; _ } ->
|
|
|
|
Format.fprintf fmt "%a%a%a%a%a" expr e punctuation "." punctuation "\""
|
|
|
|
IdentName.format_t field punctuation "\""
|
2022-11-17 19:13:35 +03:00
|
|
|
| EStruct { name; fields } ->
|
2022-11-21 19:11:53 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@]" StructName.format_t name
|
2022-09-30 17:37:43 +03:00
|
|
|
punctuation "{"
|
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " punctuation ";")
|
|
|
|
(fun fmt (field_name, field_expr) ->
|
|
|
|
Format.fprintf fmt "%a%a%a%a@ %a" punctuation "\""
|
2022-11-21 12:12:45 +03:00
|
|
|
StructField.format_t field_name punctuation "\"" punctuation "="
|
|
|
|
expr field_expr))
|
|
|
|
(StructField.Map.bindings fields)
|
2022-09-30 17:37:43 +03:00
|
|
|
punctuation "}"
|
2022-11-17 19:13:35 +03:00
|
|
|
| EStructAccess { e; field; _ } ->
|
|
|
|
Format.fprintf fmt "%a%a%a%a%a" expr e punctuation "." punctuation "\""
|
2022-11-21 12:12:45 +03:00
|
|
|
StructField.format_t field punctuation "\""
|
2022-11-17 19:13:35 +03:00
|
|
|
| EInj { e; cons; _ } ->
|
|
|
|
Format.fprintf fmt "%a@ %a" EnumConstructor.format_t cons expr e
|
|
|
|
| EMatch { e; cases; _ } ->
|
2022-09-30 17:37:43 +03:00
|
|
|
Format.fprintf fmt "@[<hov 0>%a@ @[<hov 2>%a@]@ %a@ %a@]" keyword "match"
|
2022-11-17 19:13:35 +03:00
|
|
|
expr e keyword "with"
|
2022-09-30 17:37:43 +03:00
|
|
|
(Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
|
|
|
(fun fmt (cons_name, case_expr) ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a %a@ %a@ %a@]" punctuation "|"
|
|
|
|
enum_constructor cons_name punctuation "→" expr case_expr))
|
2022-11-21 12:12:45 +03:00
|
|
|
(EnumConstructor.Map.bindings cases)
|
2022-11-17 19:13:35 +03:00
|
|
|
| EScopeCall { scope; args } ->
|
2022-10-21 16:47:17 +03:00
|
|
|
Format.pp_open_hovbox fmt 2;
|
|
|
|
ScopeName.format_t fmt scope;
|
|
|
|
Format.pp_print_space fmt ();
|
|
|
|
keyword fmt "of";
|
|
|
|
Format.pp_print_space fmt ();
|
|
|
|
Format.pp_open_hvbox fmt 2;
|
|
|
|
punctuation fmt "{";
|
|
|
|
Format.pp_print_list
|
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " punctuation ";")
|
|
|
|
(fun fmt (field_name, field_expr) ->
|
|
|
|
Format.fprintf fmt "%a%a%a%a@ %a" punctuation "\"" ScopeVar.format_t
|
|
|
|
field_name punctuation "\"" punctuation "=" expr field_expr)
|
|
|
|
fmt
|
2022-11-21 12:12:45 +03:00
|
|
|
(ScopeVar.Map.bindings args);
|
2022-10-21 16:47:17 +03:00
|
|
|
Format.pp_close_box fmt ();
|
|
|
|
punctuation fmt "}";
|
|
|
|
Format.pp_close_box fmt ()
|
2022-09-30 17:37:43 +03:00
|
|
|
|
|
|
|
let typ_debug = typ None
|
|
|
|
let typ ctx = typ (Some ctx)
|
2022-10-12 14:45:04 +03:00
|
|
|
let expr_debug ?debug = expr_aux ?debug None Bindlib.empty_ctxt
|
|
|
|
let expr ?debug ctx = expr_aux ?debug (Some ctx) Bindlib.empty_ctxt
|