1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
open Catala_utils
open Shared_ast
open Ast
let struc
ctx
(fmt : Format.formatter)
(name : StructName.t)
(fields : typ StructField.Map.t) : unit =
Format.fprintf fmt "%a %a %a %a@\n@[<hov 2> %a@]@\n%a" Print.keyword "struct"
StructName.format name Print.punctuation "=" Print.punctuation "{"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (field_name, typ) ->
Format.fprintf fmt "%a%a %a" StructField.format field_name
Print.punctuation ":" (Print.typ ctx) typ))
(StructField.Map.bindings fields)
Print.punctuation "}"
let enum
ctx
(fmt : Format.formatter)
(name : EnumName.t)
(cases : typ EnumConstructor.Map.t) : unit =
Format.fprintf fmt "%a %a %a @\n@[<hov 2> %a@]" Print.keyword "enum"
EnumName.format name Print.punctuation "="
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (field_name, typ) ->
Format.fprintf fmt "%a %a%a %a" Print.punctuation "|"
EnumConstructor.format field_name Print.punctuation ":"
(Print.typ ctx) typ))
(EnumConstructor.Map.bindings cases)
let scope ?debug ctx fmt (name, (decl, _pos)) =
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@]@\n@[<v 2> %a@]"
Print.keyword "let" Print.keyword "scope" ScopeName.format name
(Format.pp_print_list ~pp_sep:Format.pp_print_space
(fun fmt (scope_var, svar) ->
Format.fprintf fmt "%a%a%a %a%a%a%a%a" Print.punctuation "("
ScopeVar.format scope_var Print.punctuation ":" (Print.typ ctx)
svar.svar_in_ty Print.punctuation "|" Print.keyword
(match Mark.remove svar.svar_io.Desugared.Ast.io_input with
| NoInput -> "internal"
| OnlyInput -> "input"
| Reentrant -> "context")
(if Mark.remove svar.svar_io.Desugared.Ast.io_output then
fun fmt () ->
Format.fprintf fmt "%a@,%a" Print.punctuation "|" Print.keyword
"output"
else fun fmt () -> Format.fprintf fmt "@<0>")
() Print.punctuation ")"))
(ScopeVar.Map.bindings decl.scope_sig)
Print.punctuation "="
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " Print.punctuation ";")
(fun fmt rule ->
match rule with
| ScopeVarDefinition { var; typ; io; e } ->
Format.fprintf fmt "@[<hov 2>%a %a %a %a %a@ %t%a@]" Print.keyword
"let" ScopeVar.format (Mark.remove var) Print.punctuation ":"
(Print.typ ctx) typ Print.punctuation "="
(fun fmt ->
match Mark.remove io.io_input with
| Reentrant ->
Print.op_style fmt "reentrant or by default";
Format.pp_print_space fmt ()
| _ -> ())
(Print.expr ?debug ()) e
| SubScopeVarDefinition { var; typ; e; _ } ->
Format.fprintf fmt "@[<hov 2>%a %a %a %a %a@ %a@]" Print.keyword
"let" ScopeVar.format (Mark.remove var) Print.punctuation ":"
(Print.typ ctx) typ Print.punctuation "=" (Print.expr ?debug ()) e
| Assertion e ->
Format.fprintf fmt "%a %a" Print.keyword "assert"
(Print.expr ?debug ()) e))
decl.scope_decl_rules
let print_topdef ctx ppf name (e, ty) =
Format.pp_open_vbox ppf 2;
let () =
Format.pp_open_hovbox ppf 2;
Print.keyword ppf "let";
Format.pp_print_space ppf ();
TopdefName.format ppf name;
Print.punctuation ppf ":";
Format.pp_print_space ppf ();
Print.typ ctx ppf ty;
Format.pp_print_space ppf ();
Print.punctuation ppf "=";
Format.pp_close_box ppf ()
in
Format.pp_print_cut ppf ();
Print.expr () ppf e;
Format.pp_close_box ppf ()
let program ?(debug : bool = false) (fmt : Format.formatter) (p : 'm program) :
unit =
let ctx = p.program_ctx in
let pp_sep fmt () =
Format.pp_print_cut fmt ();
Format.pp_print_cut fmt ()
in
Format.pp_open_vbox fmt 0;
StructName.Map.iter
(fun n s ->
struc ctx fmt n s;
pp_sep fmt ())
ctx.ctx_structs;
EnumName.Map.iter
(fun n e ->
enum ctx fmt n e;
pp_sep fmt ())
ctx.ctx_enums;
TopdefName.Map.iter
(fun name def ->
print_topdef ctx fmt name def;
pp_sep fmt ())
p.program_topdefs;
Format.pp_print_list ~pp_sep (scope ~debug ctx) fmt
(ScopeName.Map.bindings p.program_scopes);
Format.pp_close_box fmt ()