mirror of
https://github.com/CatalaLang/catala.git
synced 2024-11-08 07:51:43 +03:00
Add an explain plugin ; improve printers (#489)
This commit is contained in:
Louis Gesbert
GitHub
commit
56eaf77a5f
@ -20,7 +20,8 @@ type 'a pos = ('a, Pos.t) ed
|
||||
|
||||
let add m e = e, m
|
||||
let remove (x, _) = x
|
||||
let get (_, x) = x
|
||||
let get (_, m) = m
|
||||
let set m (x, _) = x, m
|
||||
let map f (x, m) = f x, m
|
||||
let map_mark f (a, m) = a, f m
|
||||
let copy (_, m) x = x, m
|
||||
|
||||
@ -28,6 +28,7 @@ type 'a pos = ('a, Pos.t) ed
|
||||
val add : 'm -> 'a -> ('a, 'm) ed
|
||||
val remove : ('a, 'm) ed -> 'a
|
||||
val get : ('a, 'm) ed -> 'm
|
||||
val set : 'm -> ('a, _) ed -> ('a, 'm) ed
|
||||
val map : ('a -> 'b) -> ('a, 'm) ed -> ('b, 'm) ed
|
||||
val map_mark : ('m1 -> 'm2) -> ('a, 'm1) ed -> ('a, 'm2) ed
|
||||
val copy : ('b, 'm) ed -> 'a -> ('a, 'm) ed
|
||||
|
||||
@ -54,8 +54,6 @@ let remove_prefix ~prefix s =
|
||||
sub s plen (length s - plen)
|
||||
else s
|
||||
|
||||
let format_t = Format.pp_print_string
|
||||
|
||||
(* Note: this should do, but remains incorrect for combined unicode characters
|
||||
that display as one (e.g. `e` + postfix `'`). We should switch to Uuseg at
|
||||
some poing *)
|
||||
@ -68,5 +66,7 @@ let width s =
|
||||
in
|
||||
aux 0 0
|
||||
|
||||
let format_t ppf s = Format.pp_print_as ppf (width s) s
|
||||
|
||||
module Set = Set.Make (Stdlib.String)
|
||||
module Map = Map.Make (Stdlib.String)
|
||||
|
||||
@ -72,7 +72,7 @@ module MarkedString = struct
|
||||
type info = string Mark.pos
|
||||
|
||||
let to_string (s, _) = s
|
||||
let format fmt i = Format.pp_print_string fmt (to_string i)
|
||||
let format fmt i = String.format_t fmt (to_string i)
|
||||
let equal = Mark.equal String.equal
|
||||
let compare = Mark.compare String.compare
|
||||
end
|
||||
|
||||
@ -104,6 +104,7 @@ end
|
||||
(** Various helpers *)
|
||||
|
||||
val modname_of_file : string -> string
|
||||
val get_lang : Cli.options -> Cli.input_file -> Cli.backend_lang
|
||||
|
||||
(** API available to plugins for their own registration *)
|
||||
|
||||
|
||||
@ -46,11 +46,12 @@
|
||||
(modes native js)
|
||||
(flags
|
||||
(:standard
|
||||
(:include custom_linking.sexp)))
|
||||
(:include custom_linking.sexp)
|
||||
-linkall))
|
||||
(package catala)
|
||||
(modules catala)
|
||||
(public_name catala)
|
||||
(libraries catala.driver))
|
||||
(libraries catala.driver ocamlgraph))
|
||||
|
||||
(documentation
|
||||
(package catala)
|
||||
|
||||
@ -73,20 +73,75 @@ let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
|
||||
(Re.replace sanitize_quotes ~f:(fun _ -> "\\\"") info)))
|
||||
uids
|
||||
|
||||
(* list taken from
|
||||
http://caml.inria.fr/pub/docs/manual-ocaml/lex.html#sss:keywords *)
|
||||
let ocaml_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";
|
||||
"Stdlib";
|
||||
"Runtime";
|
||||
"Oper";
|
||||
]
|
||||
|
||||
let ocaml_keywords_set = String.Set.of_list ocaml_keywords
|
||||
|
||||
let avoid_keywords (s : string) : string =
|
||||
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" | "Stdlib" | "Runtime" | "Oper" ->
|
||||
s ^ "_user"
|
||||
| _ -> s
|
||||
if String.Set.mem s ocaml_keywords_set then s ^ "_user" else s
|
||||
(* Fixme: this could cause clashes if the user program contains both e.g. [new]
|
||||
and [new_user] *)
|
||||
|
||||
@ -187,7 +242,7 @@ let format_var (fmt : Format.formatter) (v : 'm Var.t) : unit =
|
||||
~subst:(fun _ -> "_dot_")
|
||||
lowercase_name
|
||||
in
|
||||
let lowercase_name = avoid_keywords (String.to_ascii lowercase_name) in
|
||||
let lowercase_name = String.to_ascii lowercase_name in
|
||||
if
|
||||
List.mem lowercase_name ["handle_default"; "handle_default_opt"]
|
||||
|| String.begins_with_uppercase (Bindlib.name_of v)
|
||||
@ -505,6 +560,14 @@ let format_ctx
|
||||
Format.fprintf fmt "%a@\n" format_enum_decl (e, find_enum e ctx))
|
||||
(type_ordering @ scope_structs)
|
||||
|
||||
let rename_vars e =
|
||||
Expr.(
|
||||
unbox
|
||||
(rename_vars ~exclude:ocaml_keywords ~reset_context_for_closed_terms:true
|
||||
~skip_constant_binders:true ~constant_binder_name:(Some "_") e))
|
||||
|
||||
let format_expr ctx fmt e = format_expr ctx fmt (rename_vars e)
|
||||
|
||||
let rec format_scope_body_expr
|
||||
(ctx : decl_ctx)
|
||||
(fmt : Format.formatter)
|
||||
|
||||
@ -26,7 +26,17 @@
|
||||
(synopsis
|
||||
"Catala plugin that implements a different, experimental interpreter, featuring lazy and partial evaluation")
|
||||
(modules lazy_interp)
|
||||
(libraries shared_ast catala.driver))
|
||||
(flags (-linkall))
|
||||
(libraries shared_ast catala.driver ocamlgraph))
|
||||
|
||||
(library
|
||||
(name explain)
|
||||
(public_name catala.plugins.explain)
|
||||
(synopsis
|
||||
"Experiments for the explanation of computations: generates a graph of the formulas that are used for a given execution of a scope")
|
||||
(modules explain)
|
||||
(flags (-linkall))
|
||||
(libraries shared_ast catala.driver ocamlgraph))
|
||||
|
||||
(library
|
||||
(name modules)
|
||||
|
||||
1448
compiler/plugins/explain.ml
Normal file
1448
compiler/plugins/explain.ml
Normal file
File diff suppressed because it is too large
Load Diff
@ -757,6 +757,85 @@ let remove_logging_calls e =
|
||||
in
|
||||
f e
|
||||
|
||||
module DefaultBindlibCtxRename = struct
|
||||
(* This code is a copy-paste from Bindlib, they forgot to expose the default
|
||||
implementation ! *)
|
||||
type ctxt = int String.Map.t
|
||||
|
||||
let empty_ctxt = String.Map.empty
|
||||
|
||||
let split_name : string -> string * int =
|
||||
fun name ->
|
||||
let len = String.length name in
|
||||
(* [i] is the index of the first first character of the suffix. *)
|
||||
let i =
|
||||
let is_digit c = '0' <= c && c <= '9' in
|
||||
let first_digit = ref len in
|
||||
let first_non_0 = ref len in
|
||||
while !first_digit > 0 && is_digit name.[!first_digit - 1] do
|
||||
decr first_digit;
|
||||
if name.[!first_digit] <> '0' then first_non_0 := !first_digit
|
||||
done;
|
||||
!first_non_0
|
||||
in
|
||||
if i = len then name, 0
|
||||
else String.sub name 0 i, int_of_string (String.sub name i (len - i))
|
||||
|
||||
let get_suffix : string -> int -> ctxt -> int * ctxt =
|
||||
fun name suffix ctxt ->
|
||||
let n = try String.Map.find name ctxt with Not_found -> -1 in
|
||||
let suffix = if suffix > n then suffix else n + 1 in
|
||||
suffix, String.Map.add name suffix ctxt
|
||||
|
||||
let merge_name : string -> int -> string =
|
||||
fun prefix suffix ->
|
||||
if suffix > 0 then prefix ^ string_of_int suffix else prefix
|
||||
|
||||
let new_name : string -> ctxt -> string * ctxt =
|
||||
fun name ctxt ->
|
||||
let prefix, suffix = split_name name in
|
||||
let suffix, ctxt = get_suffix prefix suffix ctxt in
|
||||
merge_name prefix suffix, ctxt
|
||||
|
||||
let reserve_name : string -> ctxt -> ctxt =
|
||||
fun name ctxt ->
|
||||
let prefix, suffix = split_name name in
|
||||
try
|
||||
let n = String.Map.find prefix ctxt in
|
||||
if suffix <= n then ctxt else String.Map.add prefix suffix ctxt
|
||||
with Not_found -> String.Map.add prefix suffix ctxt
|
||||
end
|
||||
|
||||
let rename_vars
|
||||
?(exclude = ([] : string list))
|
||||
?(reset_context_for_closed_terms = false)
|
||||
?(skip_constant_binders = false)
|
||||
?(constant_binder_name = None)
|
||||
e =
|
||||
let module BindCtx = Bindlib.Ctxt (struct
|
||||
include DefaultBindlibCtxRename
|
||||
|
||||
let reset_context_for_closed_terms = reset_context_for_closed_terms
|
||||
let skip_constant_binders = skip_constant_binders
|
||||
let constant_binder_name = constant_binder_name
|
||||
end) in
|
||||
let rec aux : type a. BindCtx.ctxt -> (a, 't) gexpr -> (a, 't) gexpr boxed =
|
||||
fun ctx e ->
|
||||
match e with
|
||||
| EAbs { binder; tys }, m ->
|
||||
let vars, body, ctx = BindCtx.unmbind_in ctx binder in
|
||||
let body = aux ctx body in
|
||||
let binder = bind vars body in
|
||||
eabs binder tys m
|
||||
| e -> map ~f:(aux ctx) e
|
||||
in
|
||||
let ctx =
|
||||
List.fold_left
|
||||
(fun ctx name -> DefaultBindlibCtxRename.reserve_name name ctx)
|
||||
BindCtx.empty_ctxt exclude
|
||||
in
|
||||
aux ctx e
|
||||
|
||||
let format ppf e = Print.expr ~debug:false () ppf e
|
||||
|
||||
let rec size : type a. (a, 't) gexpr -> int =
|
||||
|
||||
@ -363,6 +363,17 @@ val remove_logging_calls :
|
||||
(** Removes all calls to [Log] unary operators in the AST, replacing them by
|
||||
their argument. *)
|
||||
|
||||
val rename_vars :
|
||||
?exclude:string list ->
|
||||
?reset_context_for_closed_terms:bool ->
|
||||
?skip_constant_binders:bool ->
|
||||
?constant_binder_name:string option ->
|
||||
('a, 'm) gexpr ->
|
||||
('a, 'm) boxed_gexpr
|
||||
(** Disambiguates all variable names in [e]. [exclude] will blacklist the given
|
||||
names (useful for keywords or built-in names) ; the other flags behave as
|
||||
defined in the bindlib documentation for module type [Rename] *)
|
||||
|
||||
val format : Format.formatter -> ('a, 'm) gexpr -> unit
|
||||
(** Simple printing without debug, use [Print.expr ()] instead to follow the
|
||||
command-line debug setting *)
|
||||
|
||||
@ -68,10 +68,20 @@ let print_log entry infos pos e =
|
||||
if Cli.globals.trace then
|
||||
match entry with
|
||||
| VarDef _ ->
|
||||
let module Printer = Print.ExprGen (struct
|
||||
include Print.ExprConciseParam
|
||||
|
||||
let bypass : type a. Format.formatter -> (a, 't) gexpr -> bool =
|
||||
fun ppf e ->
|
||||
match e with
|
||||
| EAbs _, _ ->
|
||||
Print.op_style ppf "<function>";
|
||||
true
|
||||
| _ -> false
|
||||
end) in
|
||||
Message.emit_log "%s%a %a: @{<green>%s@}" !indent_str Print.log_entry
|
||||
entry Print.uid_list infos
|
||||
(Message.unformat (fun ppf ->
|
||||
Print.expr ~hide_function_body:true () ppf e))
|
||||
(Message.unformat (fun ppf -> Printer.expr ppf e))
|
||||
| PosRecordIfTrueBool -> (
|
||||
match pos <> Pos.no_pos, Mark.remove e with
|
||||
| true, ELit (LBool true) ->
|
||||
@ -176,8 +186,11 @@ let rec evaluate_operator
|
||||
(Print.expr ()) arg),
|
||||
Expr.pos arg ))
|
||||
args)
|
||||
"Operator applied to the wrong arguments\n\
|
||||
(should not happen if the term was well-typed)"
|
||||
"Operator %a applied to the wrong arguments\n\
|
||||
(should not happen if the term was well-typed)%a"
|
||||
(Print.operator ~debug:true)
|
||||
op Expr.format
|
||||
(EApp { f = EOp { op; tys = [] }, m; args }, m)
|
||||
in
|
||||
propagate_empty_error_list args
|
||||
@@ fun args ->
|
||||
|
||||
@ -39,6 +39,11 @@ let with_color f color fmt x =
|
||||
|
||||
let pp_color_string = with_color Format.pp_print_string
|
||||
|
||||
(* Cyclic list used to choose nested paren colors *)
|
||||
let rec colors =
|
||||
let open Ocolor_types in
|
||||
blue :: cyan :: green :: yellow :: red :: magenta :: colors
|
||||
|
||||
let keyword (fmt : Format.formatter) (s : string) : unit =
|
||||
pp_color_string Ocolor_types.red fmt s
|
||||
|
||||
@ -80,12 +85,12 @@ let enum_constructor (fmt : Format.formatter) (c : EnumConstructor.t) : unit =
|
||||
let struct_field (fmt : Format.formatter) (c : StructField.t) : unit =
|
||||
Format.fprintf fmt "@{<magenta>%a@}" StructField.format_t c
|
||||
|
||||
let rec typ
|
||||
let rec typ_gen
|
||||
(ctx : decl_ctx option)
|
||||
~(colors : Ocolor_types.color4 list)
|
||||
(fmt : Format.formatter)
|
||||
(ty : typ) : unit =
|
||||
let typ = typ ctx in
|
||||
let typ = typ_gen ctx in
|
||||
let typ_with_parens ~colors (fmt : Format.formatter) (t : typ) =
|
||||
if typ_needs_parens t then (
|
||||
Format.pp_open_hvbox fmt 1;
|
||||
@ -164,6 +169,9 @@ let rec typ
|
||||
| TAny -> base_type fmt "any"
|
||||
| TClosureEnv -> base_type fmt "closure_env"
|
||||
|
||||
let typ_debug = typ_gen None ~colors
|
||||
let typ ctx = typ_gen (Some ctx) ~colors
|
||||
|
||||
let lit (fmt : Format.formatter) (l : lit) : unit =
|
||||
match l with
|
||||
| LBool b -> lit_style fmt (string_of_bool b)
|
||||
@ -453,264 +461,292 @@ module Precedence = struct
|
||||
| Contained, _ -> false
|
||||
end
|
||||
|
||||
let rec expr_aux :
|
||||
type a.
|
||||
hide_function_body:bool ->
|
||||
debug:bool ->
|
||||
Bindlib.ctxt ->
|
||||
Ocolor_types.color4 list ->
|
||||
Format.formatter ->
|
||||
(a, 't) gexpr ->
|
||||
unit =
|
||||
fun ~hide_function_body ~debug bnd_ctx colors fmt e ->
|
||||
let exprb bnd_ctx colors e =
|
||||
expr_aux ~hide_function_body ~debug bnd_ctx colors e
|
||||
in
|
||||
let exprc colors e = exprb bnd_ctx colors e in
|
||||
let expr e = exprc colors e in
|
||||
let var = if debug then var_debug else var in
|
||||
let rec skip_log : type a. (a, 't) gexpr -> (a, 't) gexpr = function
|
||||
| EApp { f = EOp { op = Log _; _ }, _; args = [e] }, _ when not debug ->
|
||||
skip_log e
|
||||
| e -> e
|
||||
in
|
||||
let e = skip_log e in
|
||||
let paren ~rhs ?(colors = colors) expr fmt e1 =
|
||||
if Precedence.needs_parens ~rhs ~context:e (skip_log e1) then (
|
||||
Format.pp_open_hvbox fmt 1;
|
||||
pp_color_string (List.hd colors) fmt "(";
|
||||
expr (List.tl colors) fmt e1;
|
||||
Format.pp_close_box fmt ();
|
||||
pp_color_string (List.hd colors) fmt ")")
|
||||
else expr colors fmt e1
|
||||
in
|
||||
let default_punct = with_color (fun fmt -> Format.pp_print_as fmt 1) in
|
||||
let lhs ?(colors = colors) ex = paren ~colors ~rhs:false ex in
|
||||
let rhs ex = paren ~rhs:true ex in
|
||||
match Mark.remove e with
|
||||
| EVar v -> var fmt v
|
||||
| EExternal eref -> Qident.format fmt eref
|
||||
| ETuple es ->
|
||||
Format.fprintf fmt "@[<hov 2>%a%a%a@]"
|
||||
(pp_color_string (List.hd colors))
|
||||
"("
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () ->
|
||||
Format.fprintf fmt "%a@ " (pp_color_string (List.hd colors)) ",")
|
||||
(fun fmt e -> lhs ~colors:(List.tl colors) exprc fmt e))
|
||||
es
|
||||
(pp_color_string (List.hd colors))
|
||||
")"
|
||||
| EArray es ->
|
||||
Format.fprintf fmt "@[<hv 2>%a %a@] %a" punctuation "["
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
|
||||
(fun fmt e -> lhs exprc fmt e))
|
||||
es punctuation "]"
|
||||
| ETupleAccess { e; index; _ } ->
|
||||
lhs exprc fmt e;
|
||||
punctuation fmt ".";
|
||||
Format.pp_print_int fmt index
|
||||
| ELit l -> lit fmt l
|
||||
| EApp { f = EAbs _, _; _ } ->
|
||||
let rec pr bnd_ctx colors fmt = function
|
||||
| EApp { f = EAbs { binder; tys }, _; args }, _ ->
|
||||
let xs, body, bnd_ctx = Bindlib.unmbind_in bnd_ctx binder in
|
||||
let xs_tau = List.mapi (fun i tau -> xs.(i), tau) tys in
|
||||
let xs_tau_arg =
|
||||
List.map2 (fun (x, tau) arg -> x, tau, arg) xs_tau args
|
||||
module type EXPR_PARAM = sig
|
||||
val bypass : Format.formatter -> ('a, 't) gexpr -> bool
|
||||
val operator : Format.formatter -> 'a operator -> unit
|
||||
val var : Format.formatter -> ('a, 't) gexpr Var.t -> unit
|
||||
val lit : Format.formatter -> lit -> unit
|
||||
val pre_map : ('a, 't) gexpr -> ('a, 't) gexpr
|
||||
end
|
||||
|
||||
module ExprGen (C : EXPR_PARAM) = struct
|
||||
let rec expr_aux :
|
||||
type a.
|
||||
Bindlib.ctxt ->
|
||||
Ocolor_types.color4 list ->
|
||||
Format.formatter ->
|
||||
(a, 't) gexpr ->
|
||||
unit =
|
||||
fun bnd_ctx colors fmt e ->
|
||||
let exprb bnd_ctx colors e = expr_aux bnd_ctx colors e in
|
||||
let exprc colors e = exprb bnd_ctx colors e in
|
||||
let expr e = exprc colors e in
|
||||
let var = C.var in
|
||||
let operator = C.operator in
|
||||
let e = C.pre_map e in
|
||||
let paren ~rhs ?(colors = colors) expr fmt e1 =
|
||||
if Precedence.needs_parens ~rhs ~context:e (C.pre_map e1) then (
|
||||
Format.pp_open_hvbox fmt 1;
|
||||
pp_color_string (List.hd colors) fmt "(";
|
||||
expr (List.tl colors) fmt e1;
|
||||
Format.pp_close_box fmt ();
|
||||
pp_color_string (List.hd colors) fmt ")")
|
||||
else expr colors fmt e1
|
||||
in
|
||||
let default_punct = with_color (fun fmt -> Format.pp_print_as fmt 1) in
|
||||
let lhs ?(colors = colors) ex = paren ~colors ~rhs:false ex in
|
||||
let rhs ex = paren ~rhs:true ex in
|
||||
if C.bypass fmt e then ()
|
||||
else
|
||||
match Mark.remove e with
|
||||
| EVar v -> var fmt v
|
||||
| EExternal eref -> Qident.format fmt eref
|
||||
| ETuple es ->
|
||||
Format.fprintf fmt "@[<hov 2>%a%a%a@]"
|
||||
(pp_color_string (List.hd colors))
|
||||
"("
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () ->
|
||||
Format.fprintf fmt "%a@ " (pp_color_string (List.hd colors)) ",")
|
||||
(fun fmt e -> lhs ~colors:(List.tl colors) exprc fmt e))
|
||||
es
|
||||
(pp_color_string (List.hd colors))
|
||||
")"
|
||||
| EArray es ->
|
||||
Format.fprintf fmt "@[<hov 2>%a %a@] %a" punctuation "["
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
|
||||
(fun fmt e -> lhs exprc fmt e))
|
||||
es punctuation "]"
|
||||
| ETupleAccess { e; index; _ } ->
|
||||
lhs exprc fmt e;
|
||||
punctuation fmt ".";
|
||||
Format.pp_print_int fmt index
|
||||
| ELit l -> C.lit fmt l
|
||||
| EApp { f = EAbs _, _; _ } ->
|
||||
let rec pr bnd_ctx colors fmt = function
|
||||
| EApp { f = EAbs { binder; tys }, _; args }, _ ->
|
||||
let xs, body, bnd_ctx = Bindlib.unmbind_in bnd_ctx binder in
|
||||
let xs_tau = List.mapi (fun i tau -> xs.(i), tau) tys in
|
||||
let xs_tau_arg =
|
||||
List.map2 (fun (x, tau) arg -> x, tau, arg) xs_tau args
|
||||
in
|
||||
Format.pp_print_list
|
||||
(fun fmt (x, tau, arg) ->
|
||||
Format.fprintf fmt
|
||||
"@[<hv 2>@[<hov 4>%a %a %a@ %a@ %a@]@ %a@;<1 -2>%a@]" keyword
|
||||
"let" var x punctuation ":" (typ_gen None ~colors) tau
|
||||
punctuation "=" (exprc colors) arg keyword "in")
|
||||
fmt xs_tau_arg;
|
||||
Format.pp_print_cut fmt ();
|
||||
rhs (pr bnd_ctx) fmt body
|
||||
| e -> rhs (exprb bnd_ctx) fmt e
|
||||
in
|
||||
Format.pp_print_list
|
||||
(fun fmt (x, tau, arg) ->
|
||||
Format.fprintf fmt
|
||||
"@[<hv 2>@[<hov 4>%a %a %a@ %a@ %a@]@ %a@;<1 -2>%a@]" keyword
|
||||
"let" var x punctuation ":" (typ None ~colors) tau punctuation "="
|
||||
(exprc colors) arg keyword "in")
|
||||
fmt xs_tau_arg;
|
||||
Format.pp_print_cut fmt ();
|
||||
rhs (pr bnd_ctx) fmt body
|
||||
| e -> rhs (exprb bnd_ctx) fmt e
|
||||
in
|
||||
Format.pp_open_vbox fmt 0;
|
||||
pr bnd_ctx colors fmt e;
|
||||
Format.pp_close_box fmt ()
|
||||
| EAbs { binder; tys } ->
|
||||
if hide_function_body then Format.fprintf fmt "%a" op_style "<function>"
|
||||
else
|
||||
let xs, body, bnd_ctx = Bindlib.unmbind_in bnd_ctx binder in
|
||||
let expr = exprb bnd_ctx in
|
||||
let xs_tau = List.mapi (fun i tau -> xs.(i), tau) tys in
|
||||
Format.fprintf fmt "@[<hv 0>%a @[<hv 2>%a@]@ @]%a@ %a" punctuation "λ"
|
||||
(Format.pp_print_list ~pp_sep:Format.pp_print_space (fun fmt (x, tau) ->
|
||||
punctuation fmt "(";
|
||||
Format.pp_open_hvbox fmt 2;
|
||||
var fmt x;
|
||||
punctuation fmt ":";
|
||||
Format.pp_print_space fmt ();
|
||||
typ None ~colors fmt tau;
|
||||
Format.pp_close_box fmt ();
|
||||
punctuation fmt ")"))
|
||||
xs_tau punctuation "→" (rhs expr) body
|
||||
| EApp { f = EOp { op = (Map | Filter) as op; _ }, _; args = [arg1; arg2] } ->
|
||||
Format.fprintf fmt "@[<hv 2>%a %a@ %a@]" (operator ~debug) op (lhs exprc)
|
||||
arg1 (rhs exprc) arg2
|
||||
| EApp { f = EOp { op = Log _ as op; _ }, _; args = [arg1] } ->
|
||||
Format.fprintf fmt "@[<hv 0>%a@ %a@]" (operator ~debug) op (rhs exprc) arg1
|
||||
| EApp { f = EOp { op = op0; _ }, _; args = [_; _] } ->
|
||||
let prec = Precedence.expr e in
|
||||
let rec pr colors fmt = function
|
||||
(* Flatten sequences of the same associative op *)
|
||||
| EApp { f = EOp { op; _ }, _; args = [arg1; arg2] }, _ when op = op0 -> (
|
||||
(match prec with
|
||||
| Op (And | Or | Mul | Add | Div | Sub) -> lhs pr fmt arg1
|
||||
| _ -> lhs exprc fmt arg1);
|
||||
Format.pp_open_vbox fmt 0;
|
||||
pr bnd_ctx colors fmt e;
|
||||
Format.pp_close_box fmt ()
|
||||
| EAbs { binder; tys } ->
|
||||
let xs, body, bnd_ctx = Bindlib.unmbind_in bnd_ctx binder in
|
||||
let expr = exprb bnd_ctx in
|
||||
let xs_tau = List.mapi (fun i tau -> xs.(i), tau) tys in
|
||||
Format.fprintf fmt "@[<hv 0>%a @[<hv 2>%a@]@ @]%a@ %a" punctuation "λ"
|
||||
(Format.pp_print_list ~pp_sep:Format.pp_print_space
|
||||
(fun fmt (x, tau) ->
|
||||
punctuation fmt "(";
|
||||
Format.pp_open_hvbox fmt 2;
|
||||
var fmt x;
|
||||
punctuation fmt ":";
|
||||
Format.pp_print_space fmt ();
|
||||
typ_gen None ~colors fmt tau;
|
||||
Format.pp_close_box fmt ();
|
||||
punctuation fmt ")"))
|
||||
xs_tau punctuation "→" (rhs expr) body
|
||||
| EApp
|
||||
{ f = EOp { op = (Map | Filter) as op; _ }, _; args = [arg1; arg2] }
|
||||
->
|
||||
Format.fprintf fmt "@[<hv 2>%a %a@ %a@]" operator op (lhs exprc) arg1
|
||||
(rhs exprc) arg2
|
||||
| EApp { f = EOp { op = Log _ as op; _ }, _; args = [arg1] } ->
|
||||
Format.fprintf fmt "@[<hv 0>%a@ %a@]" operator op (rhs exprc) arg1
|
||||
| EApp { f = EOp { op = op0; _ }, _; args = [_; _] } ->
|
||||
let prec = Precedence.expr e in
|
||||
let rec pr colors fmt = function
|
||||
(* Flatten sequences of the same associative op *)
|
||||
| EApp { f = EOp { op; _ }, _; args = [arg1; arg2] }, _ when op = op0
|
||||
-> (
|
||||
(match prec with
|
||||
| Op (And | Or | Mul | Add | Div | Sub) -> lhs pr fmt arg1
|
||||
| _ -> lhs exprc fmt arg1);
|
||||
Format.pp_print_space fmt ();
|
||||
operator fmt op;
|
||||
Format.pp_print_char fmt ' ';
|
||||
match prec with
|
||||
| Op (And | Or | Mul | Add) -> rhs pr fmt arg2
|
||||
| _ -> rhs exprc fmt arg2)
|
||||
| e -> exprc colors fmt e
|
||||
in
|
||||
Format.pp_open_hvbox fmt 0;
|
||||
pr colors fmt e;
|
||||
Format.pp_close_box fmt ()
|
||||
| EApp { f = EOp { op; _ }, _; args = [arg1] } ->
|
||||
Format.fprintf fmt "@[<hv 2>%a@ %a@]" operator op (rhs exprc) arg1
|
||||
| EApp { f; args } ->
|
||||
Format.fprintf fmt "@[<hv 2>%a@ %a@]" (lhs exprc) f
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
|
||||
(rhs exprc))
|
||||
args
|
||||
| EIfThenElse _ ->
|
||||
let rec pr els fmt = function
|
||||
| EIfThenElse { cond; etrue; efalse }, _ ->
|
||||
Format.fprintf fmt "@[<hv 2>@[<hv 2>%a@ %a@;<1 -2>%a@]@ %a@]@ %a"
|
||||
keyword
|
||||
(if els then "else if" else "if")
|
||||
expr cond keyword "then" expr etrue (pr true) efalse
|
||||
| e ->
|
||||
Format.fprintf fmt "@[<hv 2>%a@ %a@]" keyword "else" (rhs exprc) e
|
||||
in
|
||||
Format.pp_open_hvbox fmt 0;
|
||||
pr false fmt e;
|
||||
Format.pp_close_box fmt ()
|
||||
| EOp { op; _ } -> operator fmt op
|
||||
| EDefault { excepts; just; cons } ->
|
||||
if List.length excepts = 0 then
|
||||
Format.fprintf fmt "@[<hv 1>%a%a@ %a %a%a@]"
|
||||
(default_punct (List.hd colors))
|
||||
"⟨"
|
||||
(exprc (List.tl colors))
|
||||
just
|
||||
(default_punct (List.hd colors))
|
||||
"⊢"
|
||||
(exprc (List.tl colors))
|
||||
cons
|
||||
(default_punct (List.hd colors))
|
||||
"⟩"
|
||||
else
|
||||
Format.fprintf fmt
|
||||
"@[<hv 0>@[<hov 2>%a %a@]@ @[<hov 2>%a %a@ %a %a@] %a@]"
|
||||
(default_punct (List.hd colors))
|
||||
"⟨"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () ->
|
||||
Format.fprintf fmt "%a@ " (default_punct (List.hd colors)) ",")
|
||||
(lhs ~colors:(List.tl colors) exprc))
|
||||
excepts
|
||||
(default_punct (List.hd colors))
|
||||
"|"
|
||||
(exprc (List.tl colors))
|
||||
just
|
||||
(default_punct (List.hd colors))
|
||||
"⊢"
|
||||
(exprc (List.tl colors))
|
||||
cons
|
||||
(default_punct (List.hd colors))
|
||||
"⟩"
|
||||
| EEmptyError -> lit_style fmt "∅"
|
||||
| EErrorOnEmpty e' ->
|
||||
Format.fprintf fmt "@[<hov 2>%a@ %a@]" op_style "error_empty"
|
||||
(rhs exprc) e'
|
||||
| EAssert e' ->
|
||||
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" keyword "assert" punctuation
|
||||
"(" (rhs exprc) e' punctuation ")"
|
||||
| ECatch { body; exn; handler } ->
|
||||
Format.fprintf fmt
|
||||
"@[<hv 0>@[<hov 2>%a@ %a@]@ @[<hov 2>%a@ %a ->@ %a@]@]" keyword "try"
|
||||
expr body keyword "with" except exn (rhs exprc) handler
|
||||
| ERaise exn ->
|
||||
Format.fprintf fmt "@[<hov 2>%a@ %a@]" keyword "raise" except exn
|
||||
| ELocation loc -> location fmt loc
|
||||
| EDStructAccess { e; field; _ } ->
|
||||
Format.fprintf fmt "@[<hv 2>%a%a@,%a%a%a@]" (lhs exprc) e punctuation
|
||||
"." punctuation "\"" Ident.format_t field punctuation "\""
|
||||
| EStruct { name; fields } ->
|
||||
if StructField.Map.is_empty fields then (
|
||||
punctuation fmt "{";
|
||||
StructName.format_t fmt name;
|
||||
punctuation fmt "}")
|
||||
else
|
||||
Format.fprintf fmt "@[<hv 2>%a %a@ %a@;<1 -2>%a@]" punctuation "{"
|
||||
StructName.format_t name
|
||||
(Format.pp_print_list ~pp_sep:Format.pp_print_space
|
||||
(fun fmt (field_name, field_expr) ->
|
||||
Format.fprintf fmt "@[<hv 2>%a %a@ %a%a@]" struct_field
|
||||
field_name punctuation "=" (lhs exprc) field_expr punctuation
|
||||
";"))
|
||||
(StructField.Map.bindings fields)
|
||||
punctuation "}"
|
||||
| EStructAccess { e; field; _ } ->
|
||||
Format.fprintf fmt "@[<hv 2>%a%a@,%a@]" (lhs exprc) e punctuation "."
|
||||
struct_field field
|
||||
| EInj { e; cons; _ } ->
|
||||
Format.fprintf fmt "@[<hv 2>%a@ %a@]" EnumConstructor.format_t cons
|
||||
(rhs exprc) e
|
||||
| EMatch { e; cases; _ } ->
|
||||
Format.fprintf fmt "@[<v 0>@[<hv 2>%a@ %a@ %a@]@ %a@]" keyword "match"
|
||||
(lhs exprc) e keyword "with"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
||||
(fun fmt (cons_name, case_expr) ->
|
||||
match case_expr with
|
||||
| EAbs { binder; _ }, _ ->
|
||||
let xs, body, bnd_ctx = Bindlib.unmbind_in bnd_ctx binder in
|
||||
let expr = exprb bnd_ctx in
|
||||
Format.fprintf fmt "@[<hov 2>%a %a@ %a@ %a@ %a@]" punctuation
|
||||
"|" enum_constructor cons_name
|
||||
(Format.pp_print_seq ~pp_sep:Format.pp_print_space var)
|
||||
(Array.to_seq xs) punctuation "→" (rhs expr) body
|
||||
| e ->
|
||||
Format.fprintf fmt "@[<hov 2>%a %a@ %a@ %a@]" punctuation "|"
|
||||
enum_constructor cons_name punctuation "→" (rhs exprc) e))
|
||||
(EnumConstructor.Map.bindings cases)
|
||||
| EScopeCall { scope; args } ->
|
||||
Format.pp_open_hovbox fmt 2;
|
||||
ScopeName.format_t fmt scope;
|
||||
Format.pp_print_space fmt ();
|
||||
(operator ~debug) fmt op;
|
||||
Format.pp_print_char fmt ' ';
|
||||
match prec with
|
||||
| Op (And | Or | Mul | Add) -> rhs pr fmt arg2
|
||||
| _ -> rhs exprc fmt arg2)
|
||||
| e -> exprc colors fmt e
|
||||
in
|
||||
Format.pp_open_hvbox fmt 0;
|
||||
pr colors fmt e;
|
||||
Format.pp_close_box fmt ()
|
||||
| EApp { f = EOp { op; _ }, _; args = [arg1] } ->
|
||||
Format.fprintf fmt "@[<hv 2>%a@ %a@]" (operator ~debug) op (rhs exprc) arg1
|
||||
| EApp { f; args } ->
|
||||
Format.fprintf fmt "@[<hv 2>%a@ %a@]" (lhs exprc) f
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
|
||||
(rhs exprc))
|
||||
args
|
||||
| EIfThenElse _ ->
|
||||
let rec pr els fmt = function
|
||||
| EIfThenElse { cond; etrue; efalse }, _ ->
|
||||
Format.fprintf fmt "@[<hv 2>@[<hv 2>%a@ %a@;<1 -2>%a@]@ %a@]@ %a"
|
||||
keyword
|
||||
(if els then "else if" else "if")
|
||||
expr cond keyword "then" expr etrue (pr true) efalse
|
||||
| e -> Format.fprintf fmt "@[<hv 2>%a@ %a@]" keyword "else" (rhs exprc) e
|
||||
in
|
||||
Format.pp_open_hvbox fmt 0;
|
||||
pr false fmt e;
|
||||
Format.pp_close_box fmt ()
|
||||
| EOp { op; _ } -> operator ~debug fmt op
|
||||
| EDefault { excepts; just; cons } ->
|
||||
if List.length excepts = 0 then
|
||||
Format.fprintf fmt "@[<hv 1>%a%a@ %a %a%a@]"
|
||||
(default_punct (List.hd colors))
|
||||
"⟨"
|
||||
(exprc (List.tl colors))
|
||||
just
|
||||
(default_punct (List.hd colors))
|
||||
"⊢"
|
||||
(exprc (List.tl colors))
|
||||
cons
|
||||
(default_punct (List.hd colors))
|
||||
"⟩"
|
||||
else
|
||||
Format.fprintf fmt
|
||||
"@[<hv 0>@[<hov 2>%a %a@]@ @[<hov 2>%a %a@ %a %a@] %a@]"
|
||||
(default_punct (List.hd colors))
|
||||
"⟨"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () ->
|
||||
Format.fprintf fmt "%a@ " (default_punct (List.hd colors)) ",")
|
||||
(lhs ~colors:(List.tl colors) exprc))
|
||||
excepts
|
||||
(default_punct (List.hd colors))
|
||||
"|"
|
||||
(exprc (List.tl colors))
|
||||
just
|
||||
(default_punct (List.hd colors))
|
||||
"⊢"
|
||||
(exprc (List.tl colors))
|
||||
cons
|
||||
(default_punct (List.hd colors))
|
||||
"⟩"
|
||||
| EEmptyError -> lit_style fmt "∅"
|
||||
| EErrorOnEmpty e' ->
|
||||
Format.fprintf fmt "@[<hov 2>%a@ %a@]" op_style "error_empty" (rhs exprc) e'
|
||||
| EAssert e' ->
|
||||
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" keyword "assert" punctuation "("
|
||||
(rhs exprc) e' punctuation ")"
|
||||
| ECatch { body; exn; handler } ->
|
||||
Format.fprintf fmt "@[<hv 0>@[<hov 2>%a@ %a@]@ @[<hov 2>%a@ %a ->@ %a@]@]"
|
||||
keyword "try" expr body keyword "with" except exn (rhs exprc) handler
|
||||
| ERaise exn ->
|
||||
Format.fprintf fmt "@[<hov 2>%a@ %a@]" keyword "raise" except exn
|
||||
| ELocation loc -> location fmt loc
|
||||
| EDStructAccess { e; field; _ } ->
|
||||
Format.fprintf fmt "@[<hv 2>%a%a@,%a%a%a@]" (lhs exprc) e punctuation "."
|
||||
punctuation "\"" Ident.format_t field punctuation "\""
|
||||
| EStruct { name; fields } ->
|
||||
if StructField.Map.is_empty fields then (
|
||||
punctuation fmt "{";
|
||||
StructName.format_t fmt name;
|
||||
punctuation fmt "}")
|
||||
else
|
||||
Format.fprintf fmt "@[<hv 2>%a %a@ %a@;<1 -2>%a@]" punctuation "{"
|
||||
StructName.format_t name
|
||||
(Format.pp_print_list ~pp_sep:Format.pp_print_space
|
||||
(fun fmt (field_name, field_expr) ->
|
||||
Format.fprintf fmt "@[<hv 2>%a %a@ %a%a@]" struct_field field_name
|
||||
punctuation "=" (lhs exprc) field_expr punctuation ";"))
|
||||
(StructField.Map.bindings fields)
|
||||
punctuation "}"
|
||||
| EStructAccess { e; field; _ } ->
|
||||
Format.fprintf fmt "@[<hv 2>%a%a@,%a@]" (lhs exprc) e punctuation "."
|
||||
struct_field field
|
||||
| EInj { e; cons; _ } ->
|
||||
Format.fprintf fmt "@[<hv 2>%a@ %a@]" EnumConstructor.format_t cons
|
||||
(rhs exprc) e
|
||||
| EMatch { e; cases; _ } ->
|
||||
Format.fprintf fmt "@[<v 0>@[<hv 2>%a@ %a@ %a@]@ %a@]" keyword "match"
|
||||
(lhs exprc) e keyword "with"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
|
||||
(fun fmt (cons_name, case_expr) ->
|
||||
match case_expr with
|
||||
| EAbs { binder; _ }, _ ->
|
||||
let xs, body, bnd_ctx = Bindlib.unmbind_in bnd_ctx binder in
|
||||
let expr = exprb bnd_ctx in
|
||||
Format.fprintf fmt "@[<hov 2>%a %a@ %a@ %a@ %a@]" punctuation "|"
|
||||
enum_constructor cons_name
|
||||
(Format.pp_print_seq ~pp_sep:Format.pp_print_space var)
|
||||
(Array.to_seq xs) punctuation "→" (rhs expr) body
|
||||
| e ->
|
||||
Format.fprintf fmt "@[<hov 2>%a %a@ %a@ %a@]" punctuation "|"
|
||||
enum_constructor cons_name punctuation "→" (rhs exprc) e))
|
||||
(EnumConstructor.Map.bindings cases)
|
||||
| EScopeCall { scope; args } ->
|
||||
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 "=" (rhs exprc) field_expr)
|
||||
fmt
|
||||
(ScopeVar.Map.bindings args);
|
||||
Format.pp_close_box fmt ();
|
||||
punctuation fmt "}";
|
||||
Format.pp_close_box fmt ()
|
||||
| ECustom _ -> Format.pp_print_string fmt "<obj>"
|
||||
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 "=" (rhs exprc) field_expr)
|
||||
fmt
|
||||
(ScopeVar.Map.bindings args);
|
||||
Format.pp_close_box fmt ();
|
||||
punctuation fmt "}";
|
||||
Format.pp_close_box fmt ()
|
||||
| ECustom _ -> Format.pp_print_string fmt "<obj>"
|
||||
|
||||
let rec colors =
|
||||
let open Ocolor_types in
|
||||
blue :: cyan :: green :: yellow :: red :: magenta :: colors
|
||||
let expr ppf e = expr_aux Bindlib.empty_ctxt colors ppf e
|
||||
end
|
||||
|
||||
let typ_debug = typ None ~colors
|
||||
let typ ctx = typ (Some ctx) ~colors
|
||||
module ExprConciseParam = struct
|
||||
let bypass _ _ = false
|
||||
let operator o = operator ~debug:false o
|
||||
let var = var
|
||||
let lit = lit
|
||||
|
||||
let expr ?(hide_function_body = false) ?(debug = Cli.globals.debug) () ppf e =
|
||||
expr_aux ~hide_function_body ~debug Bindlib.empty_ctxt colors ppf e
|
||||
let rec pre_map : type a. (a, 't) gexpr -> (a, 't) gexpr = function
|
||||
| EApp { f = EOp { op = Log _; _ }, _; args = [e] }, _ -> pre_map e
|
||||
| e -> e
|
||||
end
|
||||
|
||||
module ExprConcise = ExprGen (ExprConciseParam)
|
||||
|
||||
module ExprDebugParam = struct
|
||||
let bypass _ _ = false
|
||||
let operator o = operator ~debug:true o
|
||||
let var = var_debug
|
||||
let lit = lit
|
||||
let pre_map e = e
|
||||
end
|
||||
|
||||
module ExprDebug = ExprGen (ExprDebugParam)
|
||||
|
||||
let expr ?(debug = Cli.globals.debug) () ppf e =
|
||||
if debug then ExprDebug.expr ppf e else ExprConcise.expr ppf e
|
||||
|
||||
let scope_let_kind ?debug:(_debug = true) _ctx fmt k =
|
||||
match k with
|
||||
@ -1009,33 +1045,74 @@ module UserFacing = struct
|
||||
with_color (lit_raw lang) Ocolor_types.yellow ppf lit
|
||||
|
||||
let rec value :
|
||||
type a b.
|
||||
type a.
|
||||
?fallback:(Format.formatter -> (a, 't) gexpr -> unit) ->
|
||||
Cli.backend_lang ->
|
||||
Format.formatter ->
|
||||
((a, b) dcalc_lcalc, _) gexpr ->
|
||||
(a, 't) gexpr ->
|
||||
unit =
|
||||
fun lang ppf e ->
|
||||
fun ?(fallback = fun _ _ -> invalid_arg "UserPrint.value: not a value") lang
|
||||
ppf e ->
|
||||
match Mark.remove e with
|
||||
| ELit l -> lit lang ppf l
|
||||
| EArray l | ETuple l ->
|
||||
Format.fprintf ppf "@[<hov 1>[@;<0 1>%a@;<0 -1>]@]"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ")
|
||||
(value lang))
|
||||
(value ~fallback lang))
|
||||
l
|
||||
| EStruct { name; fields } ->
|
||||
Format.fprintf ppf "@[<hv 2>%a {@ %a@;<1 -2>}@]" StructName.format_t name
|
||||
(Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf (fld, e) ->
|
||||
Format.fprintf ppf "-- %a: %a" StructField.format_t fld
|
||||
(value lang) e))
|
||||
(value ~fallback lang) e))
|
||||
(StructField.Map.bindings fields)
|
||||
| EInj { name = _; cons; e } ->
|
||||
Format.fprintf ppf "%a %a" EnumConstructor.format_t cons (value lang) e
|
||||
Format.fprintf ppf "%a %a" EnumConstructor.format_t cons
|
||||
(value ~fallback lang) e
|
||||
| EEmptyError -> Format.pp_print_string ppf "ø"
|
||||
| EAbs _ -> Format.pp_print_string ppf "<function>"
|
||||
| EExternal _ -> Format.pp_print_string ppf "<external>"
|
||||
| EApp _ | EOp _ | EVar _ | EIfThenElse _ | EMatch _ | ETupleAccess _
|
||||
| EStructAccess _ | EAssert _ | EDefault _ | EErrorOnEmpty _ | ERaise _
|
||||
| ECatch _ | ELocation _ ->
|
||||
invalid_arg "UserPrint.value: not a value"
|
||||
| ECatch _ | ELocation _ | EScopeCall _ | EDStructAccess _ | ECustom _ ->
|
||||
fallback ppf e
|
||||
|
||||
(* This function is already in module [Expr], but [Expr] depends on this
|
||||
module *)
|
||||
let rec skip_wrappers : type a. (a, 'm) gexpr -> (a, 'm) gexpr = function
|
||||
| EApp { f = EOp { op = Log _; _ }, _; args = [e] }, _ -> skip_wrappers e
|
||||
| EApp { f = EApp { f = EOp { op = Log _; _ }, _; args = [f] }, _; args }, m
|
||||
->
|
||||
skip_wrappers (EApp { f; args }, m)
|
||||
| EErrorOnEmpty e, _ -> skip_wrappers e
|
||||
| EDefault { excepts = []; just = ELit (LBool true), _; cons = e }, _ ->
|
||||
skip_wrappers e
|
||||
| e -> e
|
||||
|
||||
let expr :
|
||||
type a. Cli.backend_lang -> Format.formatter -> (a, 't) gexpr -> unit =
|
||||
fun lang ->
|
||||
let rec aux_value : type a t. Format.formatter -> (a, t) gexpr -> unit =
|
||||
fun ppf e -> value ~fallback lang ppf e
|
||||
and fallback : type a t. Format.formatter -> (a, t) gexpr -> unit =
|
||||
fun ppf e ->
|
||||
let module E = ExprGen (struct
|
||||
let bypass : type a t. Format.formatter -> (a, t) gexpr -> bool =
|
||||
fun ppf e ->
|
||||
match Mark.remove e with
|
||||
| EArray _ | ETuple _ | EStruct _ | EInj _ | EEmptyError | EAbs _
|
||||
| EExternal _ ->
|
||||
aux_value ppf e;
|
||||
true
|
||||
| _ -> false
|
||||
|
||||
let operator o = operator ~debug:false o
|
||||
let var = var
|
||||
let lit = lit lang
|
||||
let pre_map = skip_wrappers
|
||||
end) in
|
||||
E.expr ppf e
|
||||
in
|
||||
aux_value
|
||||
end
|
||||
|
||||
@ -51,15 +51,35 @@ val except : Format.formatter -> except -> unit
|
||||
val var : Format.formatter -> 'e Var.t -> unit
|
||||
val var_debug : Format.formatter -> 'e Var.t -> unit
|
||||
|
||||
val expr :
|
||||
?hide_function_body:bool ->
|
||||
?debug:bool ->
|
||||
unit ->
|
||||
Format.formatter ->
|
||||
('a, 'm) gexpr ->
|
||||
unit
|
||||
(** Same as [expr], but with a debug flag that defaults to [!Cli.debug_flag]. If
|
||||
[~hide_function_body:true], prints "<function>" for [EAbs] nodes *)
|
||||
val expr : ?debug:bool -> unit -> Format.formatter -> ('a, 'm) gexpr -> unit
|
||||
(** Expression printer.
|
||||
|
||||
@param debug
|
||||
(default to the global setting) turns on printing of logging nodes,
|
||||
variable indices and operator suffixes. See the interface below for more
|
||||
detailed control. *)
|
||||
|
||||
(** {2 Generic expression printer interface} *)
|
||||
|
||||
module type EXPR_PARAM = sig
|
||||
val bypass : Format.formatter -> ('a, 't) gexpr -> bool
|
||||
(** can be used to customise printing of any specific nodes or subtrees: will
|
||||
cancel normal printing upon returning [true]. *)
|
||||
|
||||
val operator : Format.formatter -> 'a operator -> unit
|
||||
val var : Format.formatter -> ('a, 't) gexpr Var.t -> unit
|
||||
val lit : Format.formatter -> lit -> unit
|
||||
|
||||
val pre_map : ('a, 't) gexpr -> ('a, 't) gexpr
|
||||
(** pre-processing on expressions: can be used to skip log calls, etc. *)
|
||||
end
|
||||
|
||||
module ExprGen (C : EXPR_PARAM) : sig
|
||||
val expr : Format.formatter -> ('a, 't) gexpr -> unit
|
||||
end
|
||||
|
||||
module ExprConciseParam : EXPR_PARAM
|
||||
module ExprDebugParam : EXPR_PARAM
|
||||
|
||||
(** {1 Debugging versions that don't require a context} *)
|
||||
|
||||
@ -90,11 +110,18 @@ module UserFacing : sig
|
||||
val lit_to_string : Cli.backend_lang -> lit -> string
|
||||
|
||||
val value :
|
||||
?fallback:(Format.formatter -> ('a, 't) gexpr -> unit) ->
|
||||
Cli.backend_lang ->
|
||||
Format.formatter ->
|
||||
((_, _) dcalc_lcalc, _) gexpr ->
|
||||
('a, 't) gexpr ->
|
||||
unit
|
||||
(** @raise Invalid_argument
|
||||
if the supplied expression is a custom/external or anything that is not
|
||||
a value *)
|
||||
(** Prints a value in a localised format, intended to be read by an end-user.
|
||||
|
||||
@param fallback
|
||||
is called upon non-value expressions (by default, [Invalid_argument] is
|
||||
raised) *)
|
||||
|
||||
val expr : Cli.backend_lang -> Format.formatter -> (_, _) gexpr -> unit
|
||||
(** This combines the user-facing value printer and the generic expression
|
||||
printer to handle all AST nodes *)
|
||||
end
|
||||
|
||||
@ -26,7 +26,8 @@ type 'e vars = ('a, 't) naked_gexpr Bindlib.mvar constraint 'e = ('a, 't) gexpr
|
||||
|
||||
let make (name : string) : 'e t = Bindlib.new_var (fun x -> EVar x) name
|
||||
let compare = Bindlib.compare_vars
|
||||
let eq = Bindlib.eq_vars
|
||||
let equal = Bindlib.eq_vars
|
||||
let hash = Bindlib.hash_var
|
||||
|
||||
let translate (v : 'e1 t) : 'e2 t =
|
||||
Bindlib.copy_var v (fun x -> EVar x) (Bindlib.name_of v)
|
||||
@ -76,6 +77,7 @@ module Set = struct
|
||||
let of_list l = of_list (List.map t l)
|
||||
let elements s = elements s |> List.map get
|
||||
let diff s1 s2 = diff s1 s2
|
||||
let iter f s = iter (fun x -> f (get x)) s
|
||||
|
||||
(* Add more as needed *)
|
||||
end
|
||||
|
||||
@ -26,7 +26,8 @@ type 'e vars = ('a, 't) naked_gexpr Bindlib.mvar constraint 'e = ('a, 't) gexpr
|
||||
|
||||
val make : string -> 'e t
|
||||
val compare : 'e t -> 'e t -> int
|
||||
val eq : 'e t -> 'e t -> bool
|
||||
val equal : 'e t -> 'e t -> bool
|
||||
val hash : 'e t -> int
|
||||
|
||||
val translate : 'e1 t -> 'e2 t
|
||||
(** Needed when converting from one AST type to another. See the note of caution
|
||||
@ -49,6 +50,7 @@ module Set : sig
|
||||
val of_list : 'e var list -> 'e t
|
||||
val elements : 'e t -> 'e var list
|
||||
val diff : 'e t -> 'e t -> 'e t
|
||||
val iter : ('e var -> unit) -> 'e t -> unit
|
||||
end
|
||||
|
||||
(** Wrapper over [Map.S] but with a type variable for the AST type parameters.
|
||||
|
||||
@ -122,7 +122,7 @@ let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : typed expr) :
|
||||
cons;
|
||||
},
|
||||
_ )
|
||||
when List.exists (fun x' -> Var.eq x x') ctx.input_vars ->
|
||||
when List.exists (fun x' -> Var.equal x x') ctx.input_vars ->
|
||||
(* scope variables*)
|
||||
cons
|
||||
| EAbs { binder; tys = [(TLit TUnit, _)] } ->
|
||||
|
||||
@ -6,7 +6,8 @@ declaration scope S:
|
||||
|
||||
scope S:
|
||||
definition a equals
|
||||
let a equals true in
|
||||
let a equals false in
|
||||
let a equals a or true in
|
||||
a
|
||||
```
|
||||
|
||||
@ -21,3 +22,52 @@ $ catala Interpret_Lcalc -s S --avoid_exceptions --optimize
|
||||
[RESULT] Computation successful! Results:
|
||||
[RESULT] a = ESome true
|
||||
```
|
||||
|
||||
```catala-test-inline
|
||||
$ catala ocaml
|
||||
|
||||
(** This file has been generated by the Catala compiler, do not edit! *)
|
||||
|
||||
open Runtime_ocaml.Runtime
|
||||
|
||||
[@@@ocaml.warning "-4-26-27-32-41-42"]
|
||||
|
||||
|
||||
module S = struct
|
||||
type t = {a: bool}
|
||||
end
|
||||
|
||||
module SIn = struct
|
||||
type t = {a_in: unit -> bool}
|
||||
end
|
||||
|
||||
|
||||
|
||||
let s (s_in: SIn.t) : S.t =
|
||||
let a_: unit -> bool = s_in.SIn.a_in in
|
||||
let a_: bool =
|
||||
try
|
||||
(handle_default
|
||||
{filename = ""; start_line=0; start_column=1;
|
||||
end_line=0; end_column=1; law_headings=[]}
|
||||
([|(fun (_: unit) -> a_ ())|]) (fun (_: unit) -> true)
|
||||
(fun (_: unit) ->
|
||||
handle_default
|
||||
{filename = ""; start_line=0; start_column=1;
|
||||
end_line=0; end_column=1; law_headings=[]} ([||])
|
||||
(fun (_: unit) -> true)
|
||||
(fun (_: unit) -> (let a_ : bool = false
|
||||
in
|
||||
(let a_ : bool = (o_or a_ true) in
|
||||
a_)))))
|
||||
with
|
||||
EmptyError -> (raise (NoValueProvided
|
||||
{filename = "tests/test_name_resolution/good/let_in2.catala_en";
|
||||
start_line=5; start_column=18; end_line=5; end_column=19;
|
||||
law_headings=["Article"]})) in
|
||||
{S.a = a_}
|
||||
let () =
|
||||
Runtime_ocaml.Runtime.register_module "Let_in2"
|
||||
[ "S", Obj.repr s ]
|
||||
"todo-module-hash"
|
||||
```
|
||||
|
||||
Loading…
Reference in New Issue
Block a user