mirror of
https://github.com/CatalaLang/catala.git
synced 2024-09-19 16:28:12 +03:00
move printing of program & scope to the Print module
This commit is contained in:
adelaett
parent
12d85570e8
commit
618ff0518d
@ -229,7 +229,7 @@ let driver source_file (options : Cli.options) : int =
|
||||
@@ fun fmt ->
|
||||
if Option.is_some options.ex_scope then
|
||||
Format.fprintf fmt "%a\n"
|
||||
(Shared_ast.Scope.format ~debug:options.debug prgm.decl_ctx)
|
||||
(Shared_ast.Print.scope ~debug:options.debug prgm.decl_ctx)
|
||||
( scope_uid,
|
||||
Option.get
|
||||
(Shared_ast.Scope.fold_left ~init:None
|
||||
@ -357,7 +357,7 @@ let driver source_file (options : Cli.options) : int =
|
||||
@@ fun fmt ->
|
||||
if Option.is_some options.ex_scope then
|
||||
Format.fprintf fmt "%a\n"
|
||||
(Shared_ast.Scope.format ~debug:options.debug prgm.decl_ctx)
|
||||
(Shared_ast.Print.scope ~debug:options.debug prgm.decl_ctx)
|
||||
(scope_uid, Shared_ast.Program.get_scope_body prgm scope_uid)
|
||||
else
|
||||
let prgrm_lcalc_expr =
|
||||
|
||||
@ -448,3 +448,153 @@ let typ_debug = typ None
|
||||
let typ ctx = typ (Some ctx)
|
||||
let expr_debug ?debug = expr_aux ?debug None Bindlib.empty_ctxt
|
||||
let expr ?debug ctx = expr_aux ?debug (Some ctx) Bindlib.empty_ctxt
|
||||
|
||||
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
|
||||
Format.fprintf fmt "@[<hov 2>%a %a %a %a %a %a@; %a @;%a @]@,%a" keyword
|
||||
"let"
|
||||
(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 _ =
|
||||
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 "=";
|
||||
let _ =
|
||||
Format.pp_open_vbox fmt 2;
|
||||
Format.pp_print_cut fmt ();
|
||||
Format.pp_print_cut fmt ();
|
||||
let _ =
|
||||
Format.pp_open_vbox fmt 2;
|
||||
scope_body_expr ~debug ctx fmt body;
|
||||
Format.pp_close_box fmt ()
|
||||
in
|
||||
Format.pp_close_box fmt ()
|
||||
in
|
||||
Format.pp_close_box fmt ()
|
||||
in
|
||||
Format.pp_force_newline fmt ()
|
||||
|
||||
let enum
|
||||
?(debug = false)
|
||||
decl_ctx
|
||||
fmt
|
||||
((n, c) : EnumName.t * typ EnumConstructor.Map.t) =
|
||||
Format.fprintf fmt "@[<hov 0> %a %a %a@;%a@]" keyword "type" EnumName.format_t
|
||||
n punctuation "="
|
||||
(fun fmt b ->
|
||||
ListLabels.iter b ~f:(fun (n, ty) ->
|
||||
Format.fprintf fmt "@[%a %a %a %a@]@;" punctuation "|"
|
||||
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) =
|
||||
Format.fprintf fmt "@[<hov 0> %a %a %a@;%a%a%a@]" keyword "type"
|
||||
StructName.format_t n punctuation "=" punctuation "{"
|
||||
(fun fmt b ->
|
||||
ListLabels.iter b ~f:(fun (n, ty) ->
|
||||
Format.fprintf fmt "@[%a%a %a%a@]@;" StructField.format_t n keyword
|
||||
":"
|
||||
(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
|
||||
|
||||
@ -57,3 +57,13 @@ val expr_debug :
|
||||
unit
|
||||
|
||||
val typ_debug : Format.formatter -> typ -> unit
|
||||
|
||||
val scope :
|
||||
?debug:bool ->
|
||||
decl_ctx ->
|
||||
Format.formatter ->
|
||||
ScopeName.t * ('a, 'm mark) gexpr scope_body ->
|
||||
unit
|
||||
|
||||
val program :
|
||||
?debug:bool -> Format.formatter -> ('a, 'm mark) gexpr program -> unit
|
||||
|
||||
@ -84,53 +84,3 @@ let equal p p' =
|
||||
let e1 = Expr.unbox @@ to_expr p s in
|
||||
let e2 = Expr.unbox @@ to_expr p s' in
|
||||
Expr.equal e1 e2)
|
||||
|
||||
let format_enum
|
||||
?(debug = false)
|
||||
decl_ctx
|
||||
fmt
|
||||
((n, c) : EnumName.t * typ EnumConstructor.Map.t) =
|
||||
Format.fprintf fmt "@[<hov 0> %a %a %a@;%a@]" Print.keyword "type"
|
||||
EnumName.format_t n Print.punctuation "="
|
||||
(fun fmt b ->
|
||||
ListLabels.iter b ~f:(fun (n, ty) ->
|
||||
Format.fprintf fmt "@[%a %a %a %a@]@;" Print.punctuation "|"
|
||||
EnumConstructor.format_t n Print.keyword "of"
|
||||
(if debug then Print.typ_debug else Print.typ decl_ctx)
|
||||
ty))
|
||||
(EnumConstructor.Map.bindings c)
|
||||
|
||||
let format_struct
|
||||
?(debug = false)
|
||||
decl_ctx
|
||||
fmt
|
||||
((n, c) : StructName.t * typ StructField.Map.t) =
|
||||
Format.fprintf fmt "@[<hov 0> %a %a %a@;%a%a%a@]" Print.keyword "type"
|
||||
StructName.format_t n Print.punctuation "=" Print.punctuation "{"
|
||||
(fun fmt b ->
|
||||
ListLabels.iter b ~f:(fun (n, ty) ->
|
||||
Format.fprintf fmt "@[%a%a %a%a@]@;" StructField.format_t n
|
||||
Print.keyword ":"
|
||||
(if debug then Print.typ_debug else Print.typ decl_ctx)
|
||||
ty Print.punctuation ";"))
|
||||
(StructField.Map.bindings c)
|
||||
Print.punctuation "}"
|
||||
|
||||
let format_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
|
||||
(format_enum ~debug decl_ctx))
|
||||
(EnumName.Map.bindings ctx_enums)
|
||||
(Format.pp_print_list ~pp_sep:Format.pp_print_cut
|
||||
(format_struct ~debug decl_ctx))
|
||||
(StructName.Map.bindings ctx_structs)
|
||||
|
||||
let format ?(debug = false) fmt p =
|
||||
format_decl_ctx ~debug p.decl_ctx fmt p.decl_ctx;
|
||||
Scope.code_item_list_format ~debug p.decl_ctx fmt p.code_items
|
||||
|
||||
@ -45,6 +45,3 @@ val equal :
|
||||
(([< dcalc | lcalc ], _) gexpr as 'e) program ->
|
||||
(([< dcalc | lcalc ], _) gexpr as 'e) program ->
|
||||
bool
|
||||
|
||||
val format :
|
||||
?debug:bool -> Format.formatter -> ('a any, 'm mark) gexpr program -> unit
|
||||
|
||||
@ -177,98 +177,6 @@ let to_expr (ctx : decl_ctx) (body : 'e scope_body) (mark_scope : 'm mark) :
|
||||
[TStruct body.scope_body_input_struct, Expr.mark_pos mark_scope]
|
||||
(Expr.mark_pos mark_scope)
|
||||
|
||||
let format_scope_let_kind ?(debug = true) _ctx fmt k =
|
||||
let _ = debug in
|
||||
match k with
|
||||
| DestructuringInputStruct -> Print.keyword fmt "get"
|
||||
| ScopeVarDefinition -> Print.keyword fmt "set"
|
||||
| SubScopeVarDefinition -> Print.keyword fmt "sub_set"
|
||||
| CallingSubScope -> Print.keyword fmt "call"
|
||||
| DestructuringSubScopeResults -> Print.keyword fmt "sub_get"
|
||||
| Assertion -> Print.keyword fmt "assert"
|
||||
|
||||
let rec format_scope_body_expr ?(debug = false) ctx fmt b : unit =
|
||||
match b with
|
||||
| Result e ->
|
||||
Format.fprintf fmt "%a %a" Print.keyword "return" (Print.expr ~debug ctx) e
|
||||
| ScopeLet
|
||||
{ scope_let_kind; scope_let_typ; scope_let_expr; scope_let_next; _ } ->
|
||||
let var, next = Bindlib.unbind scope_let_next in
|
||||
Format.fprintf fmt "@[<hov 2>%a %a %a %a %a %a@; %a @;%a @]@,%a"
|
||||
Print.keyword "let"
|
||||
(format_scope_let_kind ~debug ctx)
|
||||
scope_let_kind
|
||||
(if debug then Print.var_debug else Print.var)
|
||||
var Print.punctuation ":" (Print.typ ctx) scope_let_typ Print.punctuation
|
||||
"=" (Print.expr ~debug ctx) scope_let_expr Print.keyword "in"
|
||||
(format_scope_body_expr ~debug ctx)
|
||||
next
|
||||
|
||||
let format_scope_body ?(debug = false) ctx fmt (n, l) : unit =
|
||||
let { scope_body_input_struct; scope_body_output_struct; scope_body_expr } =
|
||||
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 var, body = Bindlib.unbind scope_body_expr in
|
||||
|
||||
let _ =
|
||||
Format.pp_open_hbox fmt ();
|
||||
Print.keyword fmt "let scope";
|
||||
Format.pp_print_space fmt ();
|
||||
ScopeName.format_t fmt n;
|
||||
Format.pp_print_space fmt ();
|
||||
Print.punctuation fmt "(";
|
||||
(if debug then Print.var_debug else Print.var) fmt var;
|
||||
Print.punctuation fmt ":";
|
||||
Format.pp_print_space fmt ();
|
||||
(if debug then Print.typ_debug else Print.typ ctx) fmt input_typ;
|
||||
Print.punctuation fmt ")";
|
||||
Print.punctuation fmt ":";
|
||||
Format.pp_print_space fmt ();
|
||||
(if debug then Print.typ_debug else Print.typ ctx) fmt output_typ;
|
||||
Format.pp_print_space fmt ();
|
||||
Print.punctuation fmt "=";
|
||||
let _ =
|
||||
Format.pp_open_vbox fmt 2;
|
||||
Format.pp_print_cut fmt ();
|
||||
Format.pp_print_cut fmt ();
|
||||
let _ =
|
||||
Format.pp_open_vbox fmt 2;
|
||||
(format_scope_body_expr ~debug ctx) fmt body;
|
||||
Format.pp_close_box fmt ()
|
||||
in
|
||||
Format.pp_close_box fmt ()
|
||||
in
|
||||
Format.pp_close_box fmt ()
|
||||
in
|
||||
Format.pp_force_newline fmt ()
|
||||
|
||||
let format_by_expr
|
||||
?(debug : bool = false)
|
||||
(ctx : decl_ctx)
|
||||
(fmt : Format.formatter)
|
||||
((n, s) : ScopeName.t * 'm scope_body) =
|
||||
Format.fprintf fmt "@[<hov 2>%a %a =@ %a@]" Print.keyword "let scope"
|
||||
ScopeName.format_t n (Expr.format ctx ~debug)
|
||||
(Expr.unbox
|
||||
(to_expr ctx s
|
||||
(Expr.map_mark
|
||||
(fun _ -> Marked.get_mark (ScopeName.get_info n))
|
||||
(fun ty -> ty)
|
||||
(get_body_mark s))))
|
||||
|
||||
let format
|
||||
?(debug : bool = false)
|
||||
?(byexpr : bool = true)
|
||||
(ctx : decl_ctx)
|
||||
(fmt : Format.formatter)
|
||||
((n, s) : ScopeName.t * 'm scope_body) : unit =
|
||||
if byexpr then format_by_expr ~debug ctx fmt (n, s)
|
||||
else format_scope_body ~debug ctx fmt (n, s)
|
||||
|
||||
let rec unfold
|
||||
(ctx : decl_ctx)
|
||||
(s : 'e code_item_list)
|
||||
@ -325,26 +233,3 @@ let rec free_vars scopes =
|
||||
| Cons (item, next_bind) ->
|
||||
let v, next = Bindlib.unbind next_bind in
|
||||
Var.Set.union (Var.Set.remove v (free_vars next)) (free_vars_item item)
|
||||
|
||||
let code_item_format ?(debug = false) ?(byexpr = false) decl_ctx fmt c =
|
||||
match c with
|
||||
| ScopeDef (n, b) -> format ~debug ~byexpr decl_ctx fmt (n, b)
|
||||
| Topdef (n, typ, e) ->
|
||||
Format.fprintf fmt "@[%a %a %a %a %a %a @]" Print.keyword "let topval"
|
||||
TopdefName.format_t n Print.op_style ":" (Print.typ decl_ctx) typ
|
||||
Print.op_style "="
|
||||
(Print.expr ~debug decl_ctx)
|
||||
e
|
||||
|
||||
let rec code_item_list_format ?(debug = false) ?(byexpr = 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_format ~debug ~byexpr decl_ctx)
|
||||
c
|
||||
(code_item_list_format ~debug ~byexpr decl_ctx)
|
||||
cl
|
||||
|
||||
@ -111,36 +111,6 @@ val get_body_mark : (_, 'm mark) gexpr scope_body -> 'm mark
|
||||
|
||||
(** {2 Conversions} *)
|
||||
|
||||
val format :
|
||||
?debug:bool (** [true] for debug printing *) ->
|
||||
?byexpr:bool
|
||||
(** [true] to convert to an expression and then print. [false] to print the
|
||||
actual term. *) ->
|
||||
decl_ctx ->
|
||||
Format.formatter ->
|
||||
ScopeName.t * 'e scope_body ->
|
||||
unit
|
||||
|
||||
val code_item_format :
|
||||
?debug:bool ->
|
||||
?byexpr:bool
|
||||
(** [true] to convert to an expression and then print. [false] to print the
|
||||
actual term. *) ->
|
||||
decl_ctx ->
|
||||
Format.formatter ->
|
||||
('a any, 'm mark) gexpr code_item ->
|
||||
unit
|
||||
|
||||
val code_item_list_format :
|
||||
?debug:bool ->
|
||||
?byexpr:bool
|
||||
(** [true] to convert to an expression and then print. [false] to print the
|
||||
actual term. *) ->
|
||||
decl_ctx ->
|
||||
Format.formatter ->
|
||||
('a any, 'm mark) gexpr code_item_list ->
|
||||
unit
|
||||
|
||||
val to_expr :
|
||||
decl_ctx ->
|
||||
('a any, 'm mark) gexpr scope_body ->
|
||||
|
||||
Loading…
Reference in New Issue
Block a user