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
|
|
|
|
Add overloaded operators for the common operations
This uses the same disambiguation mechanism put in place for
structures, calling the typer on individual rules on the desugared AST
to propagate types, in order to resolve ambiguous operators like `+`
to their strongly typed counterparts (`+!`, `+.`, `+$`, `+@`, `+$`) in
the translation to scopelang.
The patch includes some normalisation of the definition of all the
operators, and classifies them based on their typing policy instead of
their arity. It also adds a little more flexibility:
- a couple new operators, like `-` on date and duration
- optional type annotation on some aggregation constructions
The `Shared_ast` lib is also lightly restructured, with the `Expr`
module split into `Type`, `Operator` and `Expr`.
2022-11-29 11:47:53 +03:00
|
|
|
let op_style (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)
|
2023-02-13 17:00:23 +03:00
|
|
|
| ToplevelVar v -> TopdefName.format_t fmt (Marked.unmark v)
|
2022-08-17 19:14:30 +03:00
|
|
|
|
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
|
Add overloaded operators for the common operations
This uses the same disambiguation mechanism put in place for
structures, calling the typer on individual rules on the desugared AST
to propagate types, in order to resolve ambiguous operators like `+`
to their strongly typed counterparts (`+!`, `+.`, `+$`, `+@`, `+$`) in
the translation to scopelang.
The patch includes some normalisation of the definition of all the
operators, and classifies them based on their typing policy instead of
their arity. It also adds a little more flexibility:
- a couple new operators, like `-` on date and duration
- optional type annotation on some aggregation constructions
The `Shared_ast` lib is also lightly restructured, with the `Expr`
module split into `Type`, `Operator` and `Expr`.
2022-11-29 11:47:53 +03:00
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ %a@ " op_style "*")
|
2022-10-12 14:45:04 +03:00
|
|
|
typ)
|
2022-08-25 13:09:51 +03:00
|
|
|
ts
|
2023-04-07 12:57:14 +03:00
|
|
|
| TStruct s ->
|
|
|
|
(* match ctx with | None -> *)
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a@]" StructName.format_t s
|
|
|
|
(* | Some ctx -> Format.fprintf fmt "@[<hov 2> %a%a%a%a@]" punctuation "{"
|
|
|
|
(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 "\"" StructField.format_t field punctuation "\""
|
|
|
|
punctuation ":" typ mty)) (StructField.Map.bindings (StructName.Map.find
|
|
|
|
s ctx.ctx_structs)) punctuation "}_" StructName.format_t s *)
|
2022-09-30 17:37:43 +03:00
|
|
|
| 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 "]")
|
2023-03-28 10:52:40 +03:00
|
|
|
| TOption t ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" base_type "option" punctuation
|
|
|
|
"(" typ t punctuation ")"
|
2023-02-22 13:52:22 +03:00
|
|
|
| TArrow ([t1], t2) ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" typ_with_parens t1 op_style "→"
|
|
|
|
typ t2
|
2022-08-17 17:14:14 +03:00
|
|
|
| TArrow (t1, t2) ->
|
2023-02-22 13:52:22 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a%a%a@ %a@ %a@]" op_style "("
|
2023-01-11 13:23:08 +03:00
|
|
|
(Format.pp_print_list
|
2023-02-22 13:52:22 +03:00
|
|
|
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " op_style ",")
|
2023-01-11 13:23:08 +03:00
|
|
|
typ_with_parens)
|
2023-02-22 13:52:22 +03:00
|
|
|
t1 op_style ")" op_style "→" 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"
|
|
|
|
|
2023-03-30 19:53:07 +03:00
|
|
|
let lit (fmt : Format.formatter) (l : lit) : unit =
|
2022-08-17 17:14:14 +03:00
|
|
|
match l with
|
|
|
|
| LBool b -> lit_style fmt (string_of_bool b)
|
|
|
|
| LInt i -> lit_style fmt (Runtime.integer_to_string i)
|
|
|
|
| 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)
|
|
|
|
|
|
|
|
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
|
|
|
|
|
2023-03-30 16:30:08 +03:00
|
|
|
let operator_to_string : type a. a Op.t -> string =
|
|
|
|
let open Op in
|
|
|
|
function
|
Add overloaded operators for the common operations
This uses the same disambiguation mechanism put in place for
structures, calling the typer on individual rules on the desugared AST
to propagate types, in order to resolve ambiguous operators like `+`
to their strongly typed counterparts (`+!`, `+.`, `+$`, `+@`, `+$`) in
the translation to scopelang.
The patch includes some normalisation of the definition of all the
operators, and classifies them based on their typing policy instead of
their arity. It also adds a little more flexibility:
- a couple new operators, like `-` on date and duration
- optional type annotation on some aggregation constructions
The `Shared_ast` lib is also lightly restructured, with the `Expr`
module split into `Type`, `Operator` and `Expr`.
2022-11-29 11:47:53 +03:00
|
|
|
| Not -> "~"
|
|
|
|
| Length -> "length"
|
|
|
|
| GetDay -> "get_day"
|
|
|
|
| GetMonth -> "get_month"
|
|
|
|
| GetYear -> "get_year"
|
|
|
|
| FirstDayOfMonth -> "first_day_of_month"
|
|
|
|
| LastDayOfMonth -> "last_day_of_month"
|
2022-12-13 15:28:01 +03:00
|
|
|
| ToRat -> "to_rat"
|
|
|
|
| ToRat_int -> "to_rat_int"
|
|
|
|
| ToRat_mon -> "to_rat_mon"
|
|
|
|
| ToMoney -> "to_mon"
|
|
|
|
| ToMoney_rat -> "to_mon_rat"
|
|
|
|
| Round -> "round"
|
|
|
|
| Round_rat -> "round_rat"
|
|
|
|
| Round_mon -> "round_mon"
|
Add overloaded operators for the common operations
This uses the same disambiguation mechanism put in place for
structures, calling the typer on individual rules on the desugared AST
to propagate types, in order to resolve ambiguous operators like `+`
to their strongly typed counterparts (`+!`, `+.`, `+$`, `+@`, `+$`) in
the translation to scopelang.
The patch includes some normalisation of the definition of all the
operators, and classifies them based on their typing policy instead of
their arity. It also adds a little more flexibility:
- a couple new operators, like `-` on date and duration
- optional type annotation on some aggregation constructions
The `Shared_ast` lib is also lightly restructured, with the `Expr`
module split into `Type`, `Operator` and `Expr`.
2022-11-29 11:47:53 +03:00
|
|
|
| Log _ -> "Log"
|
|
|
|
| Minus -> "-"
|
|
|
|
| Minus_int -> "-!"
|
|
|
|
| Minus_rat -> "-."
|
|
|
|
| Minus_mon -> "-$"
|
|
|
|
| Minus_dur -> "-^"
|
|
|
|
| And -> "&&"
|
|
|
|
| Or -> "||"
|
|
|
|
| Xor -> "xor"
|
|
|
|
| Eq -> "="
|
|
|
|
| Map -> "map"
|
2022-12-12 18:02:07 +03:00
|
|
|
| Reduce -> "reduce"
|
Add overloaded operators for the common operations
This uses the same disambiguation mechanism put in place for
structures, calling the typer on individual rules on the desugared AST
to propagate types, in order to resolve ambiguous operators like `+`
to their strongly typed counterparts (`+!`, `+.`, `+$`, `+@`, `+$`) in
the translation to scopelang.
The patch includes some normalisation of the definition of all the
operators, and classifies them based on their typing policy instead of
their arity. It also adds a little more flexibility:
- a couple new operators, like `-` on date and duration
- optional type annotation on some aggregation constructions
The `Shared_ast` lib is also lightly restructured, with the `Expr`
module split into `Type`, `Operator` and `Expr`.
2022-11-29 11:47:53 +03:00
|
|
|
| Concat -> "++"
|
|
|
|
| Filter -> "filter"
|
|
|
|
| Add -> "+"
|
|
|
|
| Add_int_int -> "+!"
|
|
|
|
| Add_rat_rat -> "+."
|
|
|
|
| Add_mon_mon -> "+$"
|
2023-01-20 20:18:53 +03:00
|
|
|
| Add_dat_dur AbortOnRound -> "+@"
|
|
|
|
| Add_dat_dur RoundUp -> "+@u"
|
|
|
|
| Add_dat_dur RoundDown -> "+@d"
|
Add overloaded operators for the common operations
This uses the same disambiguation mechanism put in place for
structures, calling the typer on individual rules on the desugared AST
to propagate types, in order to resolve ambiguous operators like `+`
to their strongly typed counterparts (`+!`, `+.`, `+$`, `+@`, `+$`) in
the translation to scopelang.
The patch includes some normalisation of the definition of all the
operators, and classifies them based on their typing policy instead of
their arity. It also adds a little more flexibility:
- a couple new operators, like `-` on date and duration
- optional type annotation on some aggregation constructions
The `Shared_ast` lib is also lightly restructured, with the `Expr`
module split into `Type`, `Operator` and `Expr`.
2022-11-29 11:47:53 +03:00
|
|
|
| Add_dur_dur -> "+^"
|
|
|
|
| Sub -> "-"
|
|
|
|
| Sub_int_int -> "-!"
|
|
|
|
| Sub_rat_rat -> "-."
|
|
|
|
| Sub_mon_mon -> "-$"
|
|
|
|
| Sub_dat_dat -> "-@"
|
|
|
|
| Sub_dat_dur -> "-@^"
|
|
|
|
| Sub_dur_dur -> "-^"
|
|
|
|
| Mult -> "*"
|
|
|
|
| Mult_int_int -> "*!"
|
|
|
|
| Mult_rat_rat -> "*."
|
|
|
|
| Mult_mon_rat -> "*$"
|
|
|
|
| Mult_dur_int -> "*^"
|
|
|
|
| Div -> "/"
|
|
|
|
| Div_int_int -> "/!"
|
|
|
|
| Div_rat_rat -> "/."
|
|
|
|
| Div_mon_mon -> "/$"
|
|
|
|
| Div_mon_rat -> "/$."
|
2023-03-06 12:54:51 +03:00
|
|
|
| Div_dur_dur -> "/^"
|
Add overloaded operators for the common operations
This uses the same disambiguation mechanism put in place for
structures, calling the typer on individual rules on the desugared AST
to propagate types, in order to resolve ambiguous operators like `+`
to their strongly typed counterparts (`+!`, `+.`, `+$`, `+@`, `+$`) in
the translation to scopelang.
The patch includes some normalisation of the definition of all the
operators, and classifies them based on their typing policy instead of
their arity. It also adds a little more flexibility:
- a couple new operators, like `-` on date and duration
- optional type annotation on some aggregation constructions
The `Shared_ast` lib is also lightly restructured, with the `Expr`
module split into `Type`, `Operator` and `Expr`.
2022-11-29 11:47:53 +03:00
|
|
|
| Lt -> "<"
|
|
|
|
| Lt_int_int -> "<!"
|
|
|
|
| Lt_rat_rat -> "<."
|
|
|
|
| Lt_mon_mon -> "<$"
|
|
|
|
| Lt_dur_dur -> "<^"
|
|
|
|
| Lt_dat_dat -> "<@"
|
|
|
|
| Lte -> "<="
|
|
|
|
| Lte_int_int -> "<=!"
|
|
|
|
| Lte_rat_rat -> "<=."
|
|
|
|
| Lte_mon_mon -> "<=$"
|
|
|
|
| Lte_dur_dur -> "<=^"
|
|
|
|
| Lte_dat_dat -> "<=@"
|
|
|
|
| Gt -> ">"
|
|
|
|
| Gt_int_int -> ">!"
|
|
|
|
| Gt_rat_rat -> ">."
|
|
|
|
| Gt_mon_mon -> ">$"
|
|
|
|
| Gt_dur_dur -> ">^"
|
|
|
|
| Gt_dat_dat -> ">@"
|
|
|
|
| Gte -> ">="
|
|
|
|
| Gte_int_int -> ">=!"
|
|
|
|
| Gte_rat_rat -> ">=."
|
|
|
|
| Gte_mon_mon -> ">=$"
|
|
|
|
| Gte_dur_dur -> ">=^"
|
|
|
|
| Gte_dat_dat -> ">=@"
|
|
|
|
| Eq_int_int -> "=!"
|
|
|
|
| Eq_rat_rat -> "=."
|
|
|
|
| Eq_mon_mon -> "=$"
|
|
|
|
| Eq_dur_dur -> "=^"
|
|
|
|
| Eq_dat_dat -> "=@"
|
|
|
|
| Fold -> "fold"
|
2023-04-07 17:32:43 +03:00
|
|
|
| HandleDefault -> "handle_default"
|
|
|
|
| HandleDefaultOpt -> "handle_default_opt"
|
Add overloaded operators for the common operations
This uses the same disambiguation mechanism put in place for
structures, calling the typer on individual rules on the desugared AST
to propagate types, in order to resolve ambiguous operators like `+`
to their strongly typed counterparts (`+!`, `+.`, `+$`, `+@`, `+$`) in
the translation to scopelang.
The patch includes some normalisation of the definition of all the
operators, and classifies them based on their typing policy instead of
their arity. It also adds a little more flexibility:
- a couple new operators, like `-` on date and duration
- optional type annotation on some aggregation constructions
The `Shared_ast` lib is also lightly restructured, with the `Expr`
module split into `Type`, `Operator` and `Expr`.
2022-11-29 11:47:53 +03:00
|
|
|
|
2023-03-30 16:30:08 +03:00
|
|
|
let operator : type a. Format.formatter -> a Op.t -> unit =
|
|
|
|
fun fmt op ->
|
|
|
|
let open Op in
|
2022-08-17 17:14:14 +03:00
|
|
|
match op with
|
|
|
|
| Log (entry, infos) ->
|
Add overloaded operators for the common operations
This uses the same disambiguation mechanism put in place for
structures, calling the typer on individual rules on the desugared AST
to propagate types, in order to resolve ambiguous operators like `+`
to their strongly typed counterparts (`+!`, `+.`, `+$`, `+@`, `+$`) in
the translation to scopelang.
The patch includes some normalisation of the definition of all the
operators, and classifies them based on their typing policy instead of
their arity. It also adds a little more flexibility:
- a couple new operators, like `-` on date and duration
- optional type annotation on some aggregation constructions
The `Shared_ast` lib is also lightly restructured, with the `Expr`
module split into `Type`, `Operator` and `Expr`.
2022-11-29 11:47:53 +03:00
|
|
|
Format.fprintf fmt "%a@[<hov 2>[%a|%a]@]" op_style "log" log_entry entry
|
2022-08-17 17:14:14 +03:00
|
|
|
(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
|
Add overloaded operators for the common operations
This uses the same disambiguation mechanism put in place for
structures, calling the typer on individual rules on the desugared AST
to propagate types, in order to resolve ambiguous operators like `+`
to their strongly typed counterparts (`+!`, `+.`, `+$`, `+@`, `+$`) in
the translation to scopelang.
The patch includes some normalisation of the definition of all the
operators, and classifies them based on their typing policy instead of
their arity. It also adds a little more flexibility:
- a couple new operators, like `-` on date and duration
- optional type annotation on some aggregation constructions
The `Shared_ast` lib is also lightly restructured, with the `Expr`
module split into `Type`, `Operator` and `Expr`.
2022-11-29 11:47:53 +03:00
|
|
|
| op -> Format.fprintf fmt "%a" op_style (operator_to_string op)
|
2022-08-17 17:14:14 +03:00
|
|
|
|
|
|
|
let except (fmt : Format.formatter) (exn : except) : unit =
|
Add overloaded operators for the common operations
This uses the same disambiguation mechanism put in place for
structures, calling the typer on individual rules on the desugared AST
to propagate types, in order to resolve ambiguous operators like `+`
to their strongly typed counterparts (`+!`, `+.`, `+$`, `+@`, `+$`) in
the translation to scopelang.
The patch includes some normalisation of the definition of all the
operators, and classifies them based on their typing policy instead of
their arity. It also adds a little more flexibility:
- a couple new operators, like `-` on date and duration
- optional type annotation on some aggregation constructions
The `Shared_ast` lib is also lightly restructured, with the `Expr`
module split into `Type`, `Operator` and `Expr`.
2022-11-29 11:47:53 +03:00
|
|
|
op_style fmt
|
2022-08-17 17:14:14 +03:00
|
|
|
(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 =
|
2023-04-06 14:50:48 +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
|
2023-03-16 19:15:08 +03:00
|
|
|
let rainbow =
|
|
|
|
[
|
|
|
|
ANSITerminal.white;
|
|
|
|
ANSITerminal.red;
|
|
|
|
ANSITerminal.blue;
|
|
|
|
ANSITerminal.yellow;
|
|
|
|
ANSITerminal.green;
|
|
|
|
ANSITerminal.magenta;
|
|
|
|
ANSITerminal.cyan;
|
|
|
|
]
|
|
|
|
in
|
|
|
|
let rainbow_state = ref 0 in
|
2022-09-30 17:37:43 +03:00
|
|
|
let with_parens fmt e =
|
|
|
|
if needs_parens e then (
|
2023-03-16 19:15:08 +03:00
|
|
|
let floyd =
|
|
|
|
incr rainbow_state;
|
|
|
|
[
|
|
|
|
(* ANSITerminal.Blink; *)
|
|
|
|
List.nth rainbow (!rainbow_state mod List.length rainbow);
|
|
|
|
]
|
|
|
|
in
|
|
|
|
|
|
|
|
Cli.format_with_style floyd fmt "(";
|
2022-09-30 17:37:43 +03:00
|
|
|
expr fmt e;
|
2023-03-16 19:15:08 +03:00
|
|
|
Cli.format_with_style floyd fmt ")")
|
2022-09-30 17:37:43 +03:00
|
|
|
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
|
2023-03-16 19:15:08 +03:00
|
|
|
Format.fprintf fmt "%a%a"
|
2022-09-30 17:37:43 +03:00
|
|
|
(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
|
Add overloaded operators for the common operations
This uses the same disambiguation mechanism put in place for
structures, calling the typer on individual rules on the desugared AST
to propagate types, in order to resolve ambiguous operators like `+`
to their strongly typed counterparts (`+!`, `+.`, `+$`, `+@`, `+$`) in
the translation to scopelang.
The patch includes some normalisation of the definition of all the
operators, and classifies them based on their typing policy instead of
their arity. It also adds a little more flexibility:
- a couple new operators, like `-` on date and duration
- optional type annotation on some aggregation constructions
The `Shared_ast` lib is also lightly restructured, with the `Expr`
module split into `Type`, `Operator` and `Expr`.
2022-11-29 11:47:53 +03:00
|
|
|
| EApp { f = EOp { op = (Map | Filter) as op; _ }, _; args = [arg1; arg2] } ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" operator op with_parens arg1
|
2022-09-30 17:37:43 +03:00
|
|
|
with_parens arg2
|
Add overloaded operators for the common operations
This uses the same disambiguation mechanism put in place for
structures, calling the typer on individual rules on the desugared AST
to propagate types, in order to resolve ambiguous operators like `+`
to their strongly typed counterparts (`+!`, `+.`, `+$`, `+@`, `+$`) in
the translation to scopelang.
The patch includes some normalisation of the definition of all the
operators, and classifies them based on their typing policy instead of
their arity. It also adds a little more flexibility:
- a couple new operators, like `-` on date and duration
- optional type annotation on some aggregation constructions
The `Shared_ast` lib is also lightly restructured, with the `Expr`
module split into `Type`, `Operator` and `Expr`.
2022-11-29 11:47:53 +03:00
|
|
|
| EApp { f = EOp { op; _ }, _; args = [arg1; arg2] } ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" with_parens arg1 operator op
|
2022-09-30 17:37:43 +03:00
|
|
|
with_parens arg2
|
Add overloaded operators for the common operations
This uses the same disambiguation mechanism put in place for
structures, calling the typer on individual rules on the desugared AST
to propagate types, in order to resolve ambiguous operators like `+`
to their strongly typed counterparts (`+!`, `+.`, `+$`, `+@`, `+$`) in
the translation to scopelang.
The patch includes some normalisation of the definition of all the
operators, and classifies them based on their typing policy instead of
their arity. It also adds a little more flexibility:
- a couple new operators, like `-` on date and duration
- optional type annotation on some aggregation constructions
The `Shared_ast` lib is also lightly restructured, with the `Expr`
module split into `Type`, `Operator` and `Expr`.
2022-11-29 11:47:53 +03:00
|
|
|
| EApp { f = EOp { op = Log _; _ }, _; args = [arg1] } when not debug ->
|
2022-11-17 19:13:35 +03:00
|
|
|
expr fmt arg1
|
Add overloaded operators for the common operations
This uses the same disambiguation mechanism put in place for
structures, calling the typer on individual rules on the desugared AST
to propagate types, in order to resolve ambiguous operators like `+`
to their strongly typed counterparts (`+!`, `+.`, `+$`, `+@`, `+$`) in
the translation to scopelang.
The patch includes some normalisation of the definition of all the
operators, and classifies them based on their typing policy instead of
their arity. It also adds a little more flexibility:
- a couple new operators, like `-` on date and duration
- optional type annotation on some aggregation constructions
The `Shared_ast` lib is also lightly restructured, with the `Expr`
module split into `Type`, `Operator` and `Expr`.
2022-11-29 11:47:53 +03:00
|
|
|
| EApp { f = EOp { op; _ }, _; args = [arg1] } ->
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@]" operator 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
|
Add overloaded operators for the common operations
This uses the same disambiguation mechanism put in place for
structures, calling the typer on individual rules on the desugared AST
to propagate types, in order to resolve ambiguous operators like `+`
to their strongly typed counterparts (`+!`, `+.`, `+$`, `+@`, `+$`) in
the translation to scopelang.
The patch includes some normalisation of the definition of all the
operators, and classifies them based on their typing policy instead of
their arity. It also adds a little more flexibility:
- a couple new operators, like `-` on date and duration
- optional type annotation on some aggregation constructions
The `Shared_ast` lib is also lightly restructured, with the `Expr`
module split into `Type`, `Operator` and `Expr`.
2022-11-29 11:47:53 +03:00
|
|
|
| EOp { op; _ } -> operator 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
|
|
|
|
"⟩"
|
2023-03-30 19:53:07 +03:00
|
|
|
| EEmptyError -> lit_style fmt "∅ "
|
2022-11-17 19:13:35 +03:00
|
|
|
| EErrorOnEmpty e' ->
|
Add overloaded operators for the common operations
This uses the same disambiguation mechanism put in place for
structures, calling the typer on individual rules on the desugared AST
to propagate types, in order to resolve ambiguous operators like `+`
to their strongly typed counterparts (`+!`, `+.`, `+$`, `+@`, `+$`) in
the translation to scopelang.
The patch includes some normalisation of the definition of all the
operators, and classifies them based on their typing policy instead of
their arity. It also adds a little more flexibility:
- a couple new operators, like `-` on date and duration
- optional type annotation on some aggregation constructions
The `Shared_ast` lib is also lightly restructured, with the `Expr`
module split into `Type`, `Operator` and `Expr`.
2022-11-29 11:47:53 +03:00
|
|
|
Format.fprintf fmt "%a@ %a" op_style "error_empty" with_parens e'
|
2022-09-30 17:37:43 +03:00
|
|
|
| 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 } ->
|
2023-03-16 19:15:08 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a%a@]" 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_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)
|
2023-03-16 19:15:08 +03:00
|
|
|
punctuation "}_" StructName.format_t name
|
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; _ } ->
|
2023-03-16 19:15:08 +03:00
|
|
|
Format.fprintf fmt "%a@ %a" EnumConstructor.format_t cons with_parens e
|
2023-04-07 17:21:42 +03:00
|
|
|
| EMatch { e; cases; name }
|
|
|
|
when name = Definitions.option_enum
|
|
|
|
&&
|
|
|
|
match EnumConstructor.Map.find_opt Definitions.none_constr cases with
|
|
|
|
| Some (EAbs { binder; _ }, _) -> (
|
|
|
|
let _, body = Bindlib.unmbind binder in
|
|
|
|
match body with
|
|
|
|
| EInj { name; cons; _ }, _ ->
|
|
|
|
EnumName.equal name Definitions.option_enum
|
|
|
|
&& EnumConstructor.equal cons Definitions.none_constr
|
|
|
|
| _ -> false)
|
|
|
|
| _ -> false -> (
|
|
|
|
match EnumConstructor.Map.find Definitions.some_constr cases with
|
|
|
|
| EAbs { binder; tys = [tau] }, _ ->
|
|
|
|
let[@warning "-8"] [| x |], body = Bindlib.unmbind binder in
|
|
|
|
|
|
|
|
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@ %a@ %a@]@\n%a" keyword
|
|
|
|
"let*" var x punctuation ":" (typ ctx) tau punctuation "=" expr e
|
|
|
|
keyword "in" expr body
|
|
|
|
| _ -> assert false)
|
2022-11-17 19:13:35 +03:00
|
|
|
| EMatch { e; cases; _ } ->
|
2023-04-07 17:21:42 +03:00
|
|
|
Format.fprintf fmt "@[<v 0>@[<hov 2>%a@ %a@]@ %a@ %a@ %a@]" keyword "match"
|
|
|
|
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)
|
2023-04-07 17:21:42 +03:00
|
|
|
keyword "end"
|
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
|
2023-04-07 12:26:10 +03:00
|
|
|
|
|
|
|
let scope_let_kind ?(debug = true) _ctx fmt k =
|
|
|
|
let _ = debug in
|
|
|
|
match k with
|
|
|
|
| DestructuringInputStruct -> keyword fmt "get"
|
|
|
|
| ScopeVarDefinition -> keyword fmt "set"
|
|
|
|
| SubScopeVarDefinition -> keyword fmt "sub_set"
|
|
|
|
| CallingSubScope -> keyword fmt "call"
|
|
|
|
| DestructuringSubScopeResults -> keyword fmt "sub_get"
|
|
|
|
| Assertion -> keyword fmt "assert"
|
|
|
|
|
|
|
|
let rec scope_body_expr ?(debug = false) ctx fmt b : unit =
|
|
|
|
match b with
|
|
|
|
| Result e -> Format.fprintf fmt "%a %a" keyword "return" (expr ~debug ctx) e
|
|
|
|
| ScopeLet
|
|
|
|
{
|
|
|
|
scope_let_kind = kind;
|
|
|
|
scope_let_typ;
|
|
|
|
scope_let_expr;
|
|
|
|
scope_let_next;
|
|
|
|
_;
|
|
|
|
} ->
|
|
|
|
let x, next = Bindlib.unbind scope_let_next in
|
2023-04-07 13:09:38 +03:00
|
|
|
Format.fprintf fmt "@[<hov 2>%a %a %a %a %a %a@;%a@;%a @]@,%a" keyword "let"
|
2023-04-07 12:26:10 +03:00
|
|
|
(scope_let_kind ~debug ctx)
|
|
|
|
kind
|
|
|
|
(if debug then var_debug else var)
|
|
|
|
x punctuation ":" (typ ctx) scope_let_typ punctuation "="
|
|
|
|
(expr ~debug ctx) scope_let_expr keyword "in"
|
|
|
|
(scope_body_expr ~debug ctx)
|
|
|
|
next
|
|
|
|
|
|
|
|
let scope_body ?(debug = false) ctx fmt (n, l) : unit =
|
|
|
|
let {
|
|
|
|
scope_body_input_struct;
|
|
|
|
scope_body_output_struct;
|
|
|
|
scope_body_expr = body;
|
|
|
|
} =
|
|
|
|
l
|
|
|
|
in
|
|
|
|
|
|
|
|
let input_typ = TStruct scope_body_input_struct, Pos.no_pos in
|
|
|
|
let output_typ = TStruct scope_body_output_struct, Pos.no_pos in
|
|
|
|
|
|
|
|
let x, body = Bindlib.unbind body in
|
|
|
|
|
|
|
|
let _ =
|
2023-04-07 12:57:14 +03:00
|
|
|
Format.pp_open_vbox fmt 2;
|
2023-04-07 12:26:10 +03:00
|
|
|
let _ =
|
2023-04-07 12:57:14 +03:00
|
|
|
Format.pp_open_hbox fmt ();
|
|
|
|
keyword fmt "let scope";
|
|
|
|
Format.pp_print_space fmt ();
|
|
|
|
ScopeName.format_t fmt n;
|
|
|
|
Format.pp_print_space fmt ();
|
|
|
|
punctuation fmt "(";
|
|
|
|
(if debug then var_debug else var) fmt x;
|
|
|
|
punctuation fmt ":";
|
|
|
|
Format.pp_print_space fmt ();
|
|
|
|
(if debug then typ_debug else typ ctx) fmt input_typ;
|
|
|
|
punctuation fmt ")";
|
|
|
|
punctuation fmt ":";
|
|
|
|
Format.pp_print_space fmt ();
|
|
|
|
(if debug then typ_debug else typ ctx) fmt output_typ;
|
|
|
|
Format.pp_print_space fmt ();
|
|
|
|
punctuation fmt "=";
|
2023-04-07 12:26:10 +03:00
|
|
|
Format.pp_close_box fmt ()
|
|
|
|
in
|
2023-04-07 12:57:14 +03:00
|
|
|
|
|
|
|
Format.pp_print_cut fmt ();
|
|
|
|
|
|
|
|
scope_body_expr ~debug ctx fmt body;
|
2023-04-07 12:26:10 +03:00
|
|
|
Format.pp_close_box fmt ()
|
|
|
|
in
|
2023-04-07 12:57:14 +03:00
|
|
|
()
|
2023-04-07 12:26:10 +03:00
|
|
|
|
|
|
|
let enum
|
|
|
|
?(debug = false)
|
|
|
|
decl_ctx
|
|
|
|
fmt
|
|
|
|
((n, c) : EnumName.t * typ EnumConstructor.Map.t) =
|
2023-04-07 12:57:14 +03:00
|
|
|
Format.fprintf fmt "@[<h 0>%a %a %a@;%a@]" keyword "type" EnumName.format_t n
|
|
|
|
punctuation "="
|
2023-04-07 12:26:10 +03:00
|
|
|
(fun fmt b ->
|
|
|
|
ListLabels.iter b ~f:(fun (n, ty) ->
|
2023-04-07 12:57:14 +03:00
|
|
|
Format.fprintf fmt "@[<hov2> %a %a %a %a@]@;" punctuation "|"
|
2023-04-07 12:26:10 +03:00
|
|
|
EnumConstructor.format_t n keyword "of"
|
|
|
|
(if debug then typ_debug else typ decl_ctx)
|
|
|
|
ty))
|
|
|
|
(EnumConstructor.Map.bindings c)
|
|
|
|
|
|
|
|
let struct_
|
|
|
|
?(debug = false)
|
|
|
|
decl_ctx
|
|
|
|
fmt
|
|
|
|
((n, c) : StructName.t * typ StructField.Map.t) =
|
2023-04-07 12:57:14 +03:00
|
|
|
Format.fprintf fmt "@[<hv 0>@[<hv 2>@[<h>%a %a %a@;%a@]@;%a@]%a@]@;" keyword
|
|
|
|
"type" StructName.format_t n punctuation "=" punctuation "{"
|
2023-04-07 12:26:10 +03:00
|
|
|
(fun fmt b ->
|
|
|
|
ListLabels.iter b ~f:(fun (n, ty) ->
|
2023-04-07 12:57:14 +03:00
|
|
|
Format.fprintf fmt "@[<h 2>%a%a %a%a@]@ " StructField.format_t n
|
|
|
|
keyword ":"
|
2023-04-07 12:26:10 +03:00
|
|
|
(if debug then typ_debug else typ decl_ctx)
|
|
|
|
ty punctuation ";"))
|
|
|
|
(StructField.Map.bindings c)
|
|
|
|
punctuation "}"
|
|
|
|
|
|
|
|
let decl_ctx ?(debug = false) decl_ctx (fmt : Format.formatter) (ctx : decl_ctx)
|
|
|
|
: unit =
|
|
|
|
let { ctx_enums; ctx_structs; _ } = ctx in
|
|
|
|
|
|
|
|
Format.fprintf fmt "@[<v>%a@;@;%a@] @;"
|
|
|
|
(Format.pp_print_list ~pp_sep:Format.pp_print_cut (enum ~debug decl_ctx))
|
|
|
|
(EnumName.Map.bindings ctx_enums)
|
|
|
|
(Format.pp_print_list ~pp_sep:Format.pp_print_cut (struct_ ~debug decl_ctx))
|
|
|
|
(StructName.Map.bindings ctx_structs)
|
|
|
|
|
|
|
|
let scope
|
|
|
|
?(debug : bool = false)
|
|
|
|
(ctx : decl_ctx)
|
|
|
|
(fmt : Format.formatter)
|
|
|
|
((n, s) : ScopeName.t * 'm scope_body) : unit =
|
|
|
|
scope_body ~debug ctx fmt (n, s)
|
|
|
|
|
|
|
|
let code_item ?(debug = false) decl_ctx fmt c =
|
|
|
|
match c with
|
|
|
|
| ScopeDef (n, b) -> scope ~debug decl_ctx fmt (n, b)
|
|
|
|
| Topdef (n, ty, e) ->
|
|
|
|
Format.fprintf fmt "@[%a %a %a %a %a %a @]" keyword "let topval"
|
|
|
|
TopdefName.format_t n op_style ":" (typ decl_ctx) ty op_style "="
|
|
|
|
(expr ~debug decl_ctx) e
|
|
|
|
|
|
|
|
let rec code_item_list ?(debug = false) decl_ctx fmt c =
|
|
|
|
match c with
|
|
|
|
| Nil -> ()
|
|
|
|
| Cons (c, b) ->
|
|
|
|
let _x, cl = Bindlib.unbind b in
|
|
|
|
|
|
|
|
Format.fprintf fmt "%a @.%a"
|
|
|
|
(code_item ~debug decl_ctx)
|
|
|
|
c
|
|
|
|
(code_item_list ~debug decl_ctx)
|
|
|
|
cl
|
|
|
|
|
|
|
|
let program ?(debug = false) fmt p =
|
|
|
|
decl_ctx ~debug p.decl_ctx fmt p.decl_ctx;
|
|
|
|
code_item_list ~debug p.decl_ctx fmt p.code_items
|