CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-19 16:28:12 +03:00
Code Issues Projects Releases Wiki Activity

Define ANSI style at Uid level, update ocamlformat (#501)

Browse Source
This commit is contained in:
Louis Gesbert 2023-09-01 16:39:36 +02:00 committed by GitHub
commit 1dd06a2e4e
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
42 changed files with 382 additions and 325 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.git-blame-ignore-revs
View File

@ -2,6 +2,13 @@
# Use `git config --global blame.ignoreRevsFile .git-blame-ignore-revs` to use it
# Add new reformatting commits at the top
4910158aeadad66fd9e542b736bf81fab66cd26d
8e33355eadabe2a95478c419884fab899244766b
72882f82dfc75888470a9415a5b51a7ab38e140e
ec97c386c3b49f884e6721517ef56c905fbe8e52
16c93fbb0c446bad44b710ae5dbfcd70c0df98ec
2a222f0aab95c02d50a2ed26a2b62c9ac5cf11dc
14f1ebfd0ad65bdd3408bb6ba9c254df97a59ad9
fee64d6f6f4b13da7a63fae92b78d69fc4122cc1
bd17857e904fa7381c05461674d49594f770b87b

2
.ocamlformat
View File

@ -4,7 +4,7 @@ exp-grouping = preserve
break-fun-decl = fit-or-vertical
wrap-comments
parse-docstrings
version=0.21.0
version=0.26.0
cases-exp-indent=2
indicate-multiline-delimiters=no
parens-tuple=multi-line-only

4
build_system/clerk_driver.ml
View File

@ -410,7 +410,7 @@ let collect_inline_ninja_builds
let test_name =
tested_file
|> (if reset_test_outputs then Printf.sprintf "reset_file_%s"
else Printf.sprintf "test_file_%s")
else Printf.sprintf "test_file_%s")
|> Nj.Build.unpath
in
Some
@ -479,7 +479,7 @@ let collect_all_ninja_build
let test_name =
tested_file
|> (if reset_test_outputs then Printf.sprintf "reset_file_%s"
else Printf.sprintf "test_file_%s")
else Printf.sprintf "test_file_%s")
|> Nj.Build.unpath
in
Some

4
build_system/ninja_utils.mli
View File

@ -63,8 +63,8 @@ end
(** {1 Ninja rules} *)
(** Helper module to build {{:https://ninja-build.org/manual.html#_rules} ninja
rules}. *)
(** Helper module to build
{{:https://ninja-build.org/manual.html#_rules} ninja rules}. *)
module Rule : sig
type t = { name : string; command : Expr.t; description : Expr.t option }
(** Represents the minimal ninja rule representation for Clerk:

2
catala.opam
View File

@ -43,7 +43,7 @@ depends: [
"crunch" {>= "3.0.0"}
"alcotest" {>= "1.5.0"}
"odoc" {with-doc}
"ocamlformat" {cataladevmode & = "0.21.0"}
"ocamlformat" {cataladevmode & = "0.26.0"}
"obelisk" {cataladevmode}
"conf-npm" {cataladevmode}
"conf-python-3-dev" {cataladevmode}

64
compiler/catala_utils/mark.mli
View File

@ -43,45 +43,39 @@ val equal : ('a -> 'a -> bool) -> ('a, 'm) ed -> ('a, 'm) ed -> bool
(** Visitors *)
class ['self] marked_map :
object ('self)
constraint
'self = < visit_marked :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed
; .. >
class ['self] marked_map : object ('self)
constraint
'self = < visit_marked :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed
; .. >
method visit_marked :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed
end
method visit_marked :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed
end
class ['self] marked_iter :
object ('self)
constraint
'self = < visit_marked :
'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit
; .. >
class ['self] marked_iter : object ('self)
constraint
'self = < visit_marked :
'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit
; .. >
method visit_marked :
'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit
end
method visit_marked : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit
end
class ['self] pos_map :
object ('self)
constraint
'self = < visit_pos :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed
; .. >
class ['self] pos_map : object ('self)
constraint
'self = < visit_pos :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed
; .. >
method visit_pos :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed
end
method visit_pos :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed
end
class ['self] pos_iter :
object ('self)
constraint
'self = < visit_pos :
'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit
; .. >
class ['self] pos_iter : object ('self)
constraint
'self = < visit_pos : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit
; .. >
method visit_pos : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit
end
method visit_pos : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit
end

2
compiler/catala_utils/pos.mli
View File

@ -53,7 +53,7 @@ val to_string_short : t -> string
This function is compliant with the
{{:https://www.gnu.org/prep/standards/standards.html#Errors} GNU coding
standards}. *)
standards}. *)
val format_loc_text : Format.formatter -> t -> unit
(** Open the file corresponding to the position and retrieves the text concerned

18
compiler/catala_utils/uid.ml
View File

@ -38,13 +38,21 @@ module type Id = sig
module Map : Map.S with type key = t
end
module Make (X : Info) () : Id with type info = X.info = struct
module type Style = sig
val style : Ocolor_types.style
end
module Make (X : Info) (S : Style) () : Id with type info = X.info = struct
module Ordering = struct
type t = { id : int; info : X.info }
let compare (x : t) (y : t) : int = Int.compare x.id y.id
let equal x y = Int.equal x.id y.id
let format ppf t = X.format ppf t.info
let format ppf t =
Format.pp_open_stag ppf (Ocolor_format.Ocolor_style_tag S.style);
X.format ppf t.info;
Format.pp_close_stag ppf ()
end
include Ordering
@ -75,7 +83,7 @@ module MarkedString = struct
let compare = Mark.compare String.compare
end
module Gen () = Make (MarkedString) ()
module Gen (S : Style) () = Make (MarkedString) (S) ()
(* - Modules, paths and qualified idents - *)
@ -120,8 +128,8 @@ module QualifiedMarkedString = struct
match Path.compare p1 p2 with 0 -> MarkedString.compare i1 i2 | n -> n
end
module Gen_qualified () = struct
include Make (QualifiedMarkedString) ()
module Gen_qualified (S : Style) () = struct
include Make (QualifiedMarkedString) (S) ()
let fresh path t = fresh (path, t)
let path t = fst (get_info t)

12
compiler/catala_utils/uid.mli
View File

@ -53,13 +53,19 @@ module type Id = sig
module Map : Map.S with type key = t
end
(** Used to define a consistent specific style when printing the different kinds
of uids *)
module type Style = sig
val style : Ocolor_types.style
end
(** This is the generative functor that ensures that two modules resulting from
two different calls to [Make] will be viewed as different types [t] by the
OCaml typechecker. Prevents mixing up different sorts of identifiers. *)
module Make (X : Info) () : Id with type info = X.info
module Make (X : Info) (S : Style) () : Id with type info = X.info
module Gen () : Id with type info = MarkedString.info
(** Shortcut for creating a kind of uids over marked strings *)
module Gen (S : Style) () : Id with type info = MarkedString.info
(** {2 Handling of Uids with additional path information} *)
@ -86,7 +92,7 @@ module Path : sig
end
(** Same as [Gen] but also registers path information *)
module Gen_qualified () : sig
module Gen_qualified (S : Style) () : sig
include Id with type info = Path.t * MarkedString.info
val fresh : Path.t -> MarkedString.info -> t

7
compiler/desugared/ast.ml
View File

@ -71,7 +71,12 @@ module ScopeDef = struct
module Set = Set.Make (Base)
end
module AssertionName = Uid.Gen ()
module AssertionName =
Uid.Gen
(struct
let style = Ocolor_types.(Fg (C4 hi_blue))
end)
()
(** {1 AST} *)

4
compiler/desugared/dependency.ml
View File

@ -14,8 +14,8 @@
License for the specific language governing permissions and limitations under
the License. *)
(** Scope dependencies computations using {{:http://ocamlgraph.lri.fr/}
OCamlgraph} *)
(** Scope dependencies computations using
{{:http://ocamlgraph.lri.fr/} OCamlgraph} *)
open Catala_utils
open Shared_ast

4
compiler/desugared/dependency.mli
View File

@ -14,8 +14,8 @@
License for the specific language governing permissions and limitations under
the License. *)
(** Scope dependencies computations using {{:http://ocamlgraph.lri.fr/}
OCamlgraph} *)
(** Scope dependencies computations using
{{:http://ocamlgraph.lri.fr/} OCamlgraph} *)
open Catala_utils
open Shared_ast

5
compiler/desugared/from_surface.ml
View File

@ -902,7 +902,7 @@ and disambiguate_match_and_build_expression
List.fold_left bind_match_cases (EnumConstructor.Map.empty, None, 0) cases
in
naked_expr, Option.get e_name
[@@ocamlformat "wrap-comments=false"]
[@@ocamlformat "wrap-comments=false"]
(** {1 Translating scope definitions} *)
@ -988,7 +988,8 @@ let process_rule_parameters
in
local_vars, Some (params, pos_def)
(** Translates a surface definition into condition into a desugared {!type:
(** Translates a surface definition into condition into a desugared
{!type:
Ast.rule} *)
let process_default
(ctxt : Name_resolution.context)

28
compiler/desugared/linting.ml
View File

@ -35,8 +35,8 @@ let detect_empty_definitions (p : program) : unit =
then
Message.emit_spanned_warning
(ScopeDef.get_position scope_def_key)
"In scope @{<yellow>\"%a\"@}, the variable @{<yellow>\"%a\"@} is \
declared but never defined; did you forget something?"
"In scope \"%a\", the variable \"%a\" is declared but never \
defined; did you forget something?"
ScopeName.format scope_name Ast.ScopeDef.format scope_def_key)
scope.scope_defs)
p.program_scopes
@ -94,7 +94,7 @@ let detect_identical_rules (p : program) : unit =
"These %s have identical justifications and consequences; is \
it a mistake?"
(if scope_def.scope_def_is_condition then "rules"
else "definitions"))
else "definitions"))
rules_seen)
scope.scope_defs)
p.program_scopes
@ -136,7 +136,9 @@ let detect_unused_struct_fields (p : program) : unit =
in
StructName.Map.iter
(fun s_name fields ->
if StructName.path s_name <> [] then ()
if StructName.path s_name <> [] then
(* Only check structs from the current module *)
()
else if
(not (StructField.Map.is_empty fields))
&& StructField.Map.for_all
@ -147,8 +149,7 @@ let detect_unused_struct_fields (p : program) : unit =
then
Message.emit_spanned_warning
(snd (StructName.get_info s_name))
"The structure @{<yellow>\"%a\"@} is never used; maybe it's \
unnecessary?"
"The structure \"%a\" is never used; maybe it's unnecessary?"
StructName.format s_name
else
StructField.Map.iter
@ -159,8 +160,8 @@ let detect_unused_struct_fields (p : program) : unit =
then
Message.emit_spanned_warning
(snd (StructField.get_info field))
"The field @{<yellow>\"%a\"@} of struct @{<yellow>\"%a\"@} is \
never used; maybe it's unnecessary?"
"The field \"%a\" of struct @{<yellow>\"%a\"@} is never used; \
maybe it's unnecessary?"
StructField.format field StructName.format s_name)
fields)
p.program_ctx.ctx_structs
@ -192,7 +193,9 @@ let detect_unused_enum_constructors (p : program) : unit =
in
EnumName.Map.iter
(fun e_name constructors ->
if EnumName.path e_name <> [] then ()
if EnumName.path e_name <> [] then
(* Only check enums from the current module *)
()
else if
EnumConstructor.Map.for_all
(fun cons _ ->
@ -201,8 +204,7 @@ let detect_unused_enum_constructors (p : program) : unit =
then
Message.emit_spanned_warning
(snd (EnumName.get_info e_name))
"The enumeration @{<yellow>\"%a\"@} is never used; maybe it's \
unnecessary?"
"The enumeration \"%a\" is never used; maybe it's unnecessary?"
EnumName.format e_name
else
EnumConstructor.Map.iter
@ -211,8 +213,8 @@ let detect_unused_enum_constructors (p : program) : unit =
then
Message.emit_spanned_warning
(snd (EnumConstructor.get_info constructor))
"The constructor @{<yellow>\"%a\"@} of enumeration \
@{<yellow>\"%a\"@} is never used; maybe it's unnecessary?"
"The constructor \"%a\" of enumeration \"%a\" is never used; \
maybe it's unnecessary?"
EnumConstructor.format constructor EnumName.format e_name)
constructors)
p.program_ctx.ctx_enums

11
compiler/desugared/print.ml
View File

@ -34,7 +34,7 @@ let format_exception_tree (fmt : Format.formatter) (t : exception_tree) =
| Leaf l -> l.Dependency.ExceptionVertex.label, []
| Node (sons, l) -> l.Dependency.ExceptionVertex.label, sons
in
Format.fprintf fmt "@{<yellow>\"%a\"@}" LabelName.format label;
Format.fprintf fmt "\"%a\"" LabelName.format label;
let w = String.width (fst (LabelName.get_info label)) + 2 in
if sons != [] then
let pref', prefsz' = pref ^ String.make (w + 1) ' ', prefsz + w + 2 in
@ -87,14 +87,13 @@ let print_exceptions_graph
(var : Ast.ScopeDef.t)
(g : Dependency.ExceptionsDependencies.t) =
Message.emit_result
"Printing the tree of exceptions for the definitions of variable \
@{<yellow>\"%a\"@} of scope @{<yellow>\"%a\"@}."
"Printing the tree of exceptions for the definitions of variable \"%a\" of \
scope \"%a\"."
Ast.ScopeDef.format var ScopeName.format scope;
Dependency.ExceptionsDependencies.iter_vertex
(fun ex ->
Message.emit_result
"@[<v>Definitions with label @{<yellow>\"%a\"@}:@,%a@]" LabelName.format
ex.Dependency.ExceptionVertex.label
Message.emit_result "@[<v>Definitions with label \"%a\":@,%a@]"
LabelName.format ex.Dependency.ExceptionVertex.label
(RuleName.Map.format_values Pos.format_loc_text)
ex.Dependency.ExceptionVertex.rules)
g;

20
compiler/driver.ml
View File

@ -55,8 +55,12 @@ module Passes = struct
(* Each pass takes only its cli options, then calls upon its dependent passes
(forwarding their options as needed) *)
let debug_pass_name s =
Message.emit_debug "@{<bold;magenta>=@} @{<bold>%s@} @{<bold;magenta>=@}"
(String.uppercase_ascii s)
let surface options ~link_modules : Surface.Ast.program * Cli.backend_lang =
Message.emit_debug "- SURFACE -";
debug_pass_name "surface";
let language = get_lang options options.input_file in
let prg =
Surface.Parser_driver.parse_top_level_file options.input_file language
@ -70,7 +74,7 @@ module Passes = struct
let desugared options ~link_modules :
Desugared.Ast.program * Desugared.Name_resolution.context =
let prg, _ = surface options ~link_modules in
Message.emit_debug "- DESUGARED -";
debug_pass_name "desugared";
Message.emit_debug "Name resolution...";
let ctx = Desugared.Name_resolution.form_context prg in
(* let scope_uid = get_scope_uid options backend ctx in
@ -93,7 +97,7 @@ module Passes = struct
* Desugared.Dependency.ExceptionsDependencies.t
Desugared.Ast.ScopeDef.Map.t =
let prg, ctx = desugared options ~link_modules in
Message.emit_debug "- SCOPELANG -";
debug_pass_name "scopelang";
let exceptions_graphs =
Scopelang.From_desugared.build_exceptions_graph prg
in
@ -107,7 +111,7 @@ module Passes = struct
* Desugared.Name_resolution.context
* Scopelang.Dependency.TVertex.t list =
let prg, ctx, _ = scopelang options ~link_modules in
Message.emit_debug "- DCALC -";
debug_pass_name "dcalc";
let type_ordering =
Scopelang.Dependency.check_type_cycles prg.program_ctx.ctx_structs
prg.program_ctx.ctx_enums
@ -153,7 +157,7 @@ module Passes = struct
let prg, ctx, type_ordering =
dcalc options ~link_modules ~optimize ~check_invariants
in
Message.emit_debug "- LCALC -";
debug_pass_name "lcalc";
let avoid_exceptions = avoid_exceptions || closure_conversion in
let optimize = optimize || closure_conversion in
(* --closure_conversion implies --avoid_exceptions and --optimize *)
@ -204,7 +208,7 @@ module Passes = struct
lcalc options ~link_modules ~optimize ~check_invariants ~avoid_exceptions
~closure_conversion
in
Message.emit_debug "- SCALC -";
debug_pass_name "scalc";
Scalc.From_lcalc.translate_program prg, ctx, type_ordering
end
@ -566,7 +570,7 @@ module Commands = struct
(fun ((var, _), result) ->
Message.emit_result "@[<hov 2>%s@ =@ %a@]" var
(if options.Cli.debug then Print.expr ~debug:false ()
else Print.UserFacing.value (get_lang options options.input_file))
else Print.UserFacing.value (get_lang options options.input_file))
result)
results
@ -899,7 +903,7 @@ let main () =
| Some opts, _ -> opts.Cli.plugins_dirs
| None, _ -> []
in
Message.emit_debug "- INIT -";
Passes.debug_pass_name "init";
List.iter
(fun d ->
if d = "" then ()

16
compiler/lcalc/closure_conversion.ml
View File

@ -46,7 +46,7 @@ let rec transform_closures_expr :
e
| EVar v ->
( (if Var.Set.mem v ctx.globally_bound_vars then Var.Set.empty
else Var.Set.singleton v),
else Var.Set.singleton v),
(Bindlib.box_var v, m) )
| EMatch { e; cases; name } ->
let free_vars, new_e = (transform_closures_expr ctx) e in
@ -148,13 +148,13 @@ let rec transform_closures_expr :
(Mark.get e))
[
(if extra_vars_list = [] then Expr.elit LUnit binder_mark
else
Expr.etuple
(List.map
(fun extra_var ->
Bindlib.box_var extra_var, binder_mark)
extra_vars_list)
m);
else
Expr.etuple
(List.map
(fun extra_var ->
Bindlib.box_var extra_var, binder_mark)
extra_vars_list)
m);
]
(Mark.get e);
])

6
compiler/literate/html.ml
View File

@ -188,9 +188,9 @@ let rec law_structure_to_html
href=\"https://legifrance.gouv.fr/%s/id/%s\" \
target=\"_blank\">Voir le texte sur Légifrance.gouv.fr</a>"
(if String.starts_with ~prefix:"LEGIARTI" id then "codes"
else if String.starts_with ~prefix:"JORFARTI" id then "jorf"
else if String.starts_with ~prefix:"CETATEXT" id then "ceta"
else raise Not_found)
else if String.starts_with ~prefix:"JORFARTI" id then "jorf"
else if String.starts_with ~prefix:"CETATEXT" id then "ceta"
else raise Not_found)
id
with Not_found -> "")
| _ -> "")

18
compiler/plugins/explain.ml
View File

@ -1219,15 +1219,15 @@ let to_dot lang ppf ctx env base_vars g ~base_src_url =
in
`Label (vertex_label v (* ^ "\n" ^ loc_text *))
:: `Comment loc_text
(* :: `Url
* ("http://localhost:8080/fr/examples/housing-benefits#"
* ^ Re.(
* replace_string
* (compile
* (seq [char '/'; rep1 (diff any (char '/')); str "/../"]))
* ~by:"/" (Pos.get_file pos))
* ^ "-"
* ^ string_of_int (Pos.get_start_line pos)) *)
(* :: `Url
* ("http://localhost:8080/fr/examples/housing-benefits#"
* ^ Re.(
* replace_string
* (compile
* (seq [char '/'; rep1 (diff any (char '/')); str "/../"]))
* ~by:"/" (Pos.get_file pos))
* ^ "-"
* ^ string_of_int (Pos.get_start_line pos)) *)
:: `Url
(base_src_url
^ "/"

16
compiler/scalc/ast.ml
View File

@ -18,8 +18,20 @@ open Catala_utils
open Shared_ast
module D = Dcalc.Ast
module L = Lcalc.Ast
module FuncName = Uid.Gen ()
module VarName = Uid.Gen ()
module FuncName =
Uid.Gen
(struct
let style = Ocolor_types.(Fg (C4 green))
end)
()
module VarName =
Uid.Gen
(struct
let style = Ocolor_types.(Fg (C4 hi_green))
end)
()
let dead_value = VarName.fresh ("dead_value", Pos.no_pos)
let handle_default = FuncName.fresh ("handle_default", Pos.no_pos)

4
compiler/scalc/print.ml
View File

@ -63,7 +63,7 @@ let rec format_expr
Format.fprintf fmt "%a%a%a%a%a" format_expr e1 Print.punctuation "."
Print.punctuation "\"" StructField.format field Print.punctuation "\""
| EInj (e, cons, _) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Print.enum_constructor cons
Format.fprintf fmt "@[<hov 2>%a@ %a@]" EnumConstructor.format cons
format_expr e
| ELit l -> Print.lit fmt l
| EApp ((EOp ((Map | Filter) as op), _), [arg1; arg2]) ->
@ -150,7 +150,7 @@ let rec format_statement
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt ((case, _), (arm_block, payload_name)) ->
Format.fprintf fmt "%a %a%a@ %a @[<v 2>%a@ %a@]" Print.punctuation
"|" Print.enum_constructor case Print.punctuation ":"
"|" EnumConstructor.format case Print.punctuation ":"
format_var_name payload_name Print.punctuation "→"
(format_block decl_ctx ~debug)
arm_block))

26
compiler/scalc/to_python.ml
View File

@ -498,21 +498,21 @@ let format_ctx
format_typ struct_field_type))
fields
(if StructField.Map.is_empty struct_fields then fun fmt _ ->
Format.fprintf fmt " pass"
else
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (struct_field, _) ->
Format.fprintf fmt " self.%a = %a" format_struct_field_name
struct_field format_struct_field_name struct_field))
Format.fprintf fmt " pass"
else
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (struct_field, _) ->
Format.fprintf fmt " self.%a = %a" format_struct_field_name
struct_field format_struct_field_name struct_field))
fields format_struct_name struct_name
(if not (StructField.Map.is_empty struct_fields) then
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " and@ ")
(fun fmt (struct_field, _) ->
Format.fprintf fmt "self.%a == other.%a" format_struct_field_name
struct_field format_struct_field_name struct_field)
else fun fmt _ -> Format.fprintf fmt "True")
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " and@ ")
(fun fmt (struct_field, _) ->
Format.fprintf fmt "self.%a == other.%a" format_struct_field_name
struct_field format_struct_field_name struct_field)
else fun fmt _ -> Format.fprintf fmt "True")
fields format_struct_name struct_name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",")

4
compiler/scalc/to_r.ml
View File

@ -36,9 +36,9 @@ let format_lit (fmt : Format.formatter) (l : lit Mark.pos) : unit =
| LRat i ->
Format.fprintf fmt "catala_decimal_from_fraction(%s,%s)"
(if Z.fits_nativeint (Q.num i) then Z.to_string (Q.num i)
else "\"" ^ Z.to_string (Q.num i) ^ "\"")
else "\"" ^ Z.to_string (Q.num i) ^ "\"")
(if Z.fits_nativeint (Q.den i) then Z.to_string (Q.den i)
else "\"" ^ Z.to_string (Q.den i) ^ "\"")
else "\"" ^ Z.to_string (Q.den i) ^ "\"")
| LMoney e ->
if Z.fits_nativeint e then
Format.fprintf fmt "catala_money_from_cents(%s)"

50
compiler/scopelang/dependency.ml
View File

@ -327,29 +327,29 @@ let check_type_cycles (structs : struct_ctx) (enums : enum_ctx) : TVertex.t list
cardinality > 1 *)
let sccs = TSCC.scc_list g in
(if List.length sccs < TDependencies.nb_vertex g then
let scc = List.find (fun scc -> List.length scc > 1) sccs in
let spans =
List.flatten
(List.map
(fun v ->
let var_str, var_info =
Format.asprintf "%a" TVertex.format v, TVertex.get_info v
in
let succs = TDependencies.succ_e g v in
let _, edge_pos, succ =
List.find (fun (_, _, succ) -> List.mem succ scc) succs
in
let succ_str = Format.asprintf "%a" TVertex.format succ in
[
Some ("Cycle type " ^ var_str ^ ", declared:"), Mark.get var_info;
( Some
("Used here in the definition of another cycle type "
^ succ_str
^ ":"),
edge_pos );
])
scc)
in
Message.raise_multispanned_error spans
"Cyclic dependency detected between types!");
let scc = List.find (fun scc -> List.length scc > 1) sccs in
let spans =
List.flatten
(List.map
(fun v ->
let var_str, var_info =
Format.asprintf "%a" TVertex.format v, TVertex.get_info v
in
let succs = TDependencies.succ_e g v in
let _, edge_pos, succ =
List.find (fun (_, _, succ) -> List.mem succ scc) succs
in
let succ_str = Format.asprintf "%a" TVertex.format succ in
[
Some ("Cycle type " ^ var_str ^ ", declared:"), Mark.get var_info;
( Some
("Used here in the definition of another cycle type "
^ succ_str
^ ":"),
edge_pos );
])
scc)
in
Message.raise_multispanned_error spans
"Cyclic dependency detected between types!");
List.rev (TTopologicalTraversal.fold (fun v acc -> v :: acc) g [])

6
compiler/scopelang/print.ml
View File

@ -61,9 +61,9 @@ let scope ?debug ctx fmt (name, (decl, _pos)) =
| OnlyInput -> "input"
| Reentrant -> "context")
(if Mark.remove vis.Desugared.Ast.io_output then fun fmt () ->
Format.fprintf fmt "%a@,%a" Print.punctuation "|" Print.keyword
"output"
else fun fmt () -> Format.fprintf fmt "@<0>")
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 "="

86
compiler/shared_ast/definitions.ml
View File

@ -23,17 +23,64 @@
open Catala_utils
module Runtime = Runtime_ocaml.Runtime
module ModuleName = Uid.Module
module ScopeName = Uid.Gen_qualified ()
module TopdefName = Uid.Gen_qualified ()
module StructName = Uid.Gen_qualified ()
module StructField = Uid.Gen ()
module EnumName = Uid.Gen_qualified ()
module EnumConstructor = Uid.Gen ()
module ScopeName =
Uid.Gen_qualified
(struct
let style = Ocolor_types.(Fg (C4 hi_magenta))
end)
()
module TopdefName =
Uid.Gen_qualified
(struct
let style = Ocolor_types.(Fg (C4 hi_green))
end)
()
module StructName =
Uid.Gen_qualified
(struct
let style = Ocolor_types.(Fg (C4 cyan))
end)
()
module StructField =
Uid.Gen
(struct
let style = Ocolor_types.(Fg (C4 magenta))
end)
()
module EnumName =
Uid.Gen_qualified
(struct
let style = Ocolor_types.(Fg (C4 cyan))
end)
()
module EnumConstructor =
Uid.Gen
(struct
let style = Ocolor_types.(Fg (C4 magenta))
end)
()
(** Only used by surface *)
module RuleName = Uid.Gen ()
module LabelName = Uid.Gen ()
module RuleName =
Uid.Gen
(struct
let style = Ocolor_types.(Fg (C4 hi_white))
end)
()
module LabelName =
Uid.Gen
(struct
let style = Ocolor_types.(Fg (C4 hi_cyan))
end)
()
(** Used for unresolved structs/maps in desugared *)
@ -41,9 +88,26 @@ module Ident = String
(** Only used by desugared/scopelang *)
module ScopeVar = Uid.Gen ()
module SubScopeName = Uid.Gen ()
module StateName = Uid.Gen ()
module ScopeVar =
Uid.Gen
(struct
let style = Ocolor_types.(Fg (C4 hi_white))
end)
()
module SubScopeName =
Uid.Gen
(struct
let style = Ocolor_types.(Fg (C4 hi_magenta))
end)
()
module StateName =
Uid.Gen
(struct
let style = Ocolor_types.(Fg (C4 hi_cyan))
end)
()
(** {1 Abstract syntax tree} *)

21
compiler/shared_ast/print.ml
View File

@ -27,7 +27,7 @@ let uid_list (fmt : Format.formatter) (infos : Uid.MarkedString.info list) :
(fun fmt info ->
Format.fprintf fmt
(if String.begins_with_uppercase (Mark.remove info) then "@{<red>%s@}"
else "%s")
else "%s")
(Uid.MarkedString.to_string info))
fmt infos
@ -70,15 +70,6 @@ let tlit (fmt : Format.formatter) (l : typ_lit) : unit =
| TDuration -> "duration"
| TDate -> "date")
let module_name ppf m = Format.fprintf ppf "@{<blue>%a@}" ModuleName.format m
let path ppf p =
Format.pp_print_list
~pp_sep:(fun _ () -> ())
(fun ppf m ->
Format.fprintf ppf "%a@{<cyan>.@}" module_name (Mark.remove m))
ppf p
let location (type a) (fmt : Format.formatter) (l : a glocation) : unit =
match l with
| DesugaredScopeVar { name; _ } -> ScopeVar.format fmt (Mark.remove name)
@ -88,12 +79,6 @@ let location (type a) (fmt : Format.formatter) (l : a glocation) : unit =
ScopeVar.format (Mark.remove subvar)
| ToplevelVar { name } -> TopdefName.format fmt (Mark.remove name)
let enum_constructor (fmt : Format.formatter) (c : EnumConstructor.t) : unit =
Format.fprintf fmt "@{<magenta>%a@}" EnumConstructor.format c
let struct_field (fmt : Format.formatter) (c : StructField.t) : unit =
Format.fprintf fmt "@{<magenta>%a@}" StructField.format c
let external_ref fmt er =
match Mark.remove er with
| External_value v -> TopdefName.format fmt v
@ -688,7 +673,7 @@ module ExprGen (C : EXPR_PARAM) = struct
fields punctuation "}"
| EStructAccess { e; field; _ } ->
Format.fprintf fmt "@[<hv 2>%a%a@,%a@]" (lhs exprc) e punctuation "."
struct_field field
StructField.format field
| EInj { e; cons; _ } ->
Format.fprintf fmt "@[<hv 2>%a@ %a@]" EnumConstructor.format cons
(rhs exprc) e
@ -1003,7 +988,7 @@ module UserFacing = struct
in
aux 0
(if Z.equal int_part Z.zero then None
else Some (Cli.globals.max_prec_digits - ndigits int_part))
else Some (Cli.globals.max_prec_digits - ndigits int_part))
rem
(* It would be nice to print ratios as % but that's impossible to guess.
Trying would lead to inconsistencies where some comparable numbers are in %

3
compiler/shared_ast/print.mli
View File

@ -40,10 +40,7 @@ val operator_to_string : 'a operator -> string
(** {1 Formatters} *)
val uid_list : Format.formatter -> Uid.MarkedString.info list -> unit
val enum_constructor : Format.formatter -> EnumConstructor.t -> unit
val tlit : Format.formatter -> typ_lit -> unit
val module_name : Format.formatter -> ModuleName.t -> unit
val path : Format.formatter -> ModuleName.t Mark.pos list -> unit
val location : Format.formatter -> 'a glocation -> unit
val external_ref : Format.formatter -> external_ref Mark.pos -> unit
val typ : decl_ctx -> Format.formatter -> typ -> unit

2
compiler/shared_ast/scope.ml
View File

@ -51,7 +51,7 @@ let map_exprs_in_lets :
scope_let_expr;
scope_let_typ =
(if reset_types then Mark.copy scope_let.scope_let_typ TAny
else scope_let.scope_let_typ);
else scope_let.scope_let_typ);
})
(Bindlib.bind_var (varf var_next) acc)
(Expr.Box.lift (f scope_let.scope_let_expr)))

3
compiler/shared_ast/typing.ml
View File

@ -30,6 +30,9 @@ module Any =
let equal _ _ = true
let compare _ _ = 0
end)
(struct
let style = Ocolor_types.(Fg (C4 hi_magenta))
end)
()
type unionfind_typ = naked_typ Mark.pos UnionFind.elem

7
compiler/surface/ast.ml
View File

@ -23,10 +23,11 @@ open Catala_utils
(** {1 Visitor classes for programs} *)
(** To allow for quick traversal and/or modification of this AST structure, we
provide a {{:https://en.wikipedia.org/wiki/Visitor_pattern} visitor design
pattern}. This feature is implemented via
provide a
{{:https://en.wikipedia.org/wiki/Visitor_pattern} visitor design pattern}.
This feature is implemented via
{{:https://gitlab.inria.fr/fpottier/visitors} François Pottier's OCaml
visitors library}. *)
visitors library}. *)
(** {1 Type definitions} *)

4
compiler/surface/lexer_common.ml
View File

@ -106,6 +106,6 @@ module type LocalisedLexer = sig
val lexer : Sedlexing.lexbuf -> Tokens.token
(** Entry point of the lexer, distributes to {!val: lex_code} or
{!val:lex_law} depending of the current {!val:
Surface.Lexer_common.context}. *)
{!val:lex_law} depending of the current
{!val:Surface.Lexer_common.context}. *)
end

4
compiler/surface/parser_driver.ml
View File

@ -15,8 +15,8 @@
License for the specific language governing permissions and limitations under
the License. *)
(** Wrapping module around parser and lexer that offers the {!:
Parser_driver.parse_source_file} API. *)
(** Wrapping module around parser and lexer that offers the
{!:Parser_driver.parse_source_file} API. *)
open Sedlexing
open Catala_utils

2
compiler/verification/conditions.ml
View File

@ -99,7 +99,7 @@ let disjunction (args : vc_return list) (mark : typed mark) : vc_return =
mark ))
acc list
(** [half_product \[a1,...,an\] \[b1,...,bm\] returns \[(a1,b1),...(a1,bn),...(an,b1),...(an,bm)\]] *)
(** [half_product [a1,...,an] [b1,...,bm] returns [(a1,b1),...(a1,bn),...(an,b1),...(an,bm)]] *)
let half_product (l1 : 'a list) (l2 : 'b list) : ('a * 'b) list =
l1
|> List.mapi (fun i ei ->

20
doc/catala-dev-dependencies.opam
View File

@ -1,20 +0,0 @@
opam-version: "2.0"
version: "0.8.0"
synopsis: "Virtual package listing the requirements for a complete Catala dev environment"
maintainer: ["contact@catala-lang.org"]
authors: [
"Denis Merigoux"
"Nicolas Chataing"
"Emile Rolley"
"Louis Gesbert"
"Aymeric Fromherz"
"Alain Delaët-Tixeuil"
]
license: "Apache-2.0"
homepage: "https://github.com/CatalaLang/catala"
bug-reports: "https://github.com/CatalaLang/catala/issues"
depends: [
"ocamlformat" {= "0.21.0"}
"obelisk"
"conf-npm"
]

2
flake.nix
View File

@ -24,7 +24,7 @@
buildInputs = [
pkgs.inotify-tools
ocamlPackages.merlin
pkgs.ocamlformat_0_21_0
pkgs.ocamlformat_0_26_0
ocamlPackages.ocp-indent
ocamlPackages.utop
ocamlPackages.odoc

4
french_law/catala_legifrance/api.mli
View File

@ -27,8 +27,8 @@ val get_token : string -> string -> access_token Lwt.t
(** [get_token cliend_id client_secret] retrieves the access token from the
LegiFrance API. You have to register on the
{{:https://developer.aife.economie.gouv.fr/} the official website of the
French government} to get your OAuth client ID and Secret for the LegiFrance
API *)
French government} to get your OAuth client ID and Secret for the
LegiFrance API *)
type article
type article_id

65
runtimes/jsoo/runtime.ml
View File

@ -17,36 +17,32 @@
open Js_of_ocaml
module R_ocaml = Runtime_ocaml.Runtime
class type source_position =
object
method fileName : Js.js_string Js.t Js.prop
method startLine : int Js.prop
method endLine : int Js.prop
method startColumn : int Js.prop
method endColumn : int Js.prop
method lawHeadings : Js.js_string Js.t Js.js_array Js.t Js.prop
end
class type source_position = object
method fileName : Js.js_string Js.t Js.prop
method startLine : int Js.prop
method endLine : int Js.prop
method startColumn : int Js.prop
method endColumn : int Js.prop
method lawHeadings : Js.js_string Js.t Js.js_array Js.t Js.prop
end
class type raw_event =
object
method eventType : Js.js_string Js.t Js.prop
method information : Js.js_string Js.t Js.js_array Js.t Js.prop
method sourcePosition : source_position Js.t Js.optdef Js.prop
method loggedIOJson : Js.js_string Js.t Js.prop
method loggedValueJson : Js.js_string Js.t Js.prop
end
class type raw_event = object
method eventType : Js.js_string Js.t Js.prop
method information : Js.js_string Js.t Js.js_array Js.t Js.prop
method sourcePosition : source_position Js.t Js.optdef Js.prop
method loggedIOJson : Js.js_string Js.t Js.prop
method loggedValueJson : Js.js_string Js.t Js.prop
end
class type event =
object
method data : Js.js_string Js.t Js.prop
end
class type event = object
method data : Js.js_string Js.t Js.prop
end
class type duration =
object
method years : int Js.readonly_prop
method months : int Js.readonly_prop
method days : int Js.readonly_prop
end
class type duration = object
method years : int Js.readonly_prop
method months : int Js.readonly_prop
method days : int Js.readonly_prop
end
let duration_of_jsoo d =
R_ocaml.duration_of_numbers d##.years d##.months d##.days
@ -73,16 +69,15 @@ let date_of_jsoo d =
let date_to_jsoo d = Js.string @@ R_ocaml.date_to_string d
class type event_manager =
object
method resetLog : (unit, unit) Js.meth_callback Js.meth
class type event_manager = object
method resetLog : (unit, unit) Js.meth_callback Js.meth
method retrieveEvents :
(unit, event Js.t Js.js_array Js.t) Js.meth_callback Js.meth
method retrieveEvents :
(unit, event Js.t Js.js_array Js.t) Js.meth_callback Js.meth
method retrieveRawEvents :
(unit, raw_event Js.t Js.js_array Js.t) Js.meth_callback Js.meth
end
method retrieveRawEvents :
(unit, raw_event Js.t Js.js_array Js.t) Js.meth_callback Js.meth
end
let event_manager : event_manager Js.t =
object%js

110
runtimes/jsoo/runtime.mli
View File

@ -22,74 +22,69 @@ open Js_of_ocaml
(** {1 Log events} *)
(** Information about the position of the log inside the Catala source file. *)
class type source_position =
object
method fileName : Js.js_string Js.t Js.prop
method startLine : int Js.prop
method endLine : int Js.prop
method startColumn : int Js.prop
method endColumn : int Js.prop
method lawHeadings : Js.js_string Js.t Js.js_array Js.t Js.prop
end
class type source_position = object
method fileName : Js.js_string Js.t Js.prop
method startLine : int Js.prop
method endLine : int Js.prop
method startColumn : int Js.prop
method endColumn : int Js.prop
method lawHeadings : Js.js_string Js.t Js.js_array Js.t Js.prop
end
(** Wrapper for the {!type: Runtime_ocaml.Runtime.raw_event} -- directly
collected during the program execution.*)
class type raw_event =
object
method eventType : Js.js_string Js.t Js.prop
(** There is four type of raw log events:
class type raw_event = object
method eventType : Js.js_string Js.t Js.prop
(** There is four type of raw log events:
- 'BeginCall' is emitted when a function or a subscope is called.
- 'EndCall' is emitted when a function or a subscope is exited.
- 'VariableDefinition' is emitted when a variable or a function is
defined.
- 'DecisionTaken' stores the information about the source position of
the event. *)
- 'BeginCall' is emitted when a function or a subscope is called.
- 'EndCall' is emitted when a function or a subscope is exited.
- 'VariableDefinition' is emitted when a variable or a function is
defined.
- 'DecisionTaken' stores the information about the source position of the
event. *)
method information : Js.js_string Js.t Js.js_array Js.t Js.prop
(** Represents information about a name in the code -- i.e. variable name,
subscope name, etc...
method information : Js.js_string Js.t Js.js_array Js.t Js.prop
(** Represents information about a name in the code -- i.e. variable name,
subscope name, etc...
It's a list of strings with a length varying from 2 to 3, where:
It's a list of strings with a length varying from 2 to 3, where:
- the first string is the name of the current scope -- starting with a
capitalized letter [Scope_name],
- the second string is either: the name of a scope variable or, the name
of a subscope input variable -- [a_subscope_var.input_var]
- the third string is either: a subscope name (starting with a
capitalized letter [Subscope_name] or, the [input] (resp. [output])
string -- which corresponds to the input (resp. the output) of a
function. *)
- the first string is the name of the current scope -- starting with a
capitalized letter [Scope_name],
- the second string is either: the name of a scope variable or, the name
of a subscope input variable -- [a_subscope_var.input_var]
- the third string is either: a subscope name (starting with a capitalized
letter [Subscope_name] or, the [input] (resp. [output]) string -- which
corresponds to the input (resp. the output) of a function. *)
method sourcePosition : source_position Js.t Js.optdef Js.prop
method sourcePosition : source_position Js.t Js.optdef Js.prop
method loggedIOJson : Js.js_string Js.t Js.prop
(** Serialzed [Runtime_ocaml.Runtime.io_log] corresponding to a
`VariableDefinition` raw event. *)
method loggedIOJson : Js.js_string Js.t Js.prop
(** Serialzed [Runtime_ocaml.Runtime.io_log] corresponding to a
`VariableDefinition` raw event. *)
method loggedValueJson : Js.js_string Js.t Js.prop
(** Serialized [Runtime_ocaml.Runtime.runtime_value] corresponding to a
'VariableDefinition' raw event. *)
end
method loggedValueJson : Js.js_string Js.t Js.prop
(** Serialized [Runtime_ocaml.Runtime.runtime_value] corresponding to a
'VariableDefinition' raw event. *)
end
(** Wrapper for the {!type: Runtime_ocaml.Runtime.event} -- structured log event
parsed from the {!raw_event} ones. *)
class type event =
object
method data : Js.js_string Js.t Js.prop
(** Serialized [Runtime_ocaml.Runtime.event]. *)
end
class type event = object
method data : Js.js_string Js.t Js.prop
(** Serialized [Runtime_ocaml.Runtime.event]. *)
end
class type event_manager =
object
method resetLog : (unit, unit) Js.meth_callback Js.meth
class type event_manager = object
method resetLog : (unit, unit) Js.meth_callback Js.meth
method retrieveEvents :
(unit, event Js.t Js.js_array Js.t) Js.meth_callback Js.meth
method retrieveEvents :
(unit, event Js.t Js.js_array Js.t) Js.meth_callback Js.meth
method retrieveRawEvents :
(unit, raw_event Js.t Js.js_array Js.t) Js.meth_callback Js.meth
end
method retrieveRawEvents :
(unit, raw_event Js.t Js.js_array Js.t) Js.meth_callback Js.meth
end
val event_manager : event_manager Js.t
(** JS object usable to retrieve and reset log events. *)
@ -97,12 +92,11 @@ val event_manager : event_manager Js.t
(** {1 Duration} *)
(** Simple JSOO wrapper around {!type: Runtime_ocaml.Runtime.duration}.*)
class type duration =
object
method years : int Js.readonly_prop
method months : int Js.readonly_prop
method days : int Js.readonly_prop
end
class type duration = object
method years : int Js.readonly_prop
method months : int Js.readonly_prop
method days : int Js.readonly_prop
end
val duration_of_jsoo : duration Js.t -> Runtime_ocaml.Runtime.duration
val duration_to_jsoo : Runtime_ocaml.Runtime.duration -> duration Js.t

2
runtimes/ocaml/runtime.ml
View File

@ -109,7 +109,7 @@ let decimal_to_string ~(max_prec_digits : int) (i : decimal) : string =
(fun fmt digit -> Format.fprintf fmt "%a" Z.pp_print digit))
(List.rev !digits)
(if List.length !digits - leading_zeroes !digits = max_prec_digits then "…"
else "")
else "")
let decimal_round (q : decimal) : decimal =
(* Implements the workaround by

10
tests/test_scope/good/scope_call3.catala_en
View File

@ -18,16 +18,16 @@ scope RentComputation:
```catala-test-inline
$ catala Interpret -t -s HousingComputation --debug
[DEBUG] - INIT -
[DEBUG] - SURFACE -
[DEBUG] = INIT =
[DEBUG] = SURFACE =
[DEBUG] Parsing scope_call3.catala_en
[DEBUG] - DESUGARED -
[DEBUG] = DESUGARED =
[DEBUG] Name resolution...
[DEBUG] Desugaring...
[DEBUG] Disambiguating...
[DEBUG] Linting...
[DEBUG] - SCOPELANG -
[DEBUG] - DCALC -
[DEBUG] = SCOPELANG =
[DEBUG] = DCALC =
[DEBUG] Typechecking...
[DEBUG] Translating to default calculus...
[DEBUG] Typechecking again...

22
tests/test_scope/good/scope_call4.catala_en
View File

@ -24,16 +24,16 @@ scope RentComputation:
```catala-test-inline
$ catala Interpret -s RentComputation --debug
[DEBUG] - INIT -
[DEBUG] - SURFACE -
[DEBUG] = INIT =
[DEBUG] = SURFACE =
[DEBUG] Parsing scope_call4.catala_en
[DEBUG] - DESUGARED -
[DEBUG] = DESUGARED =
[DEBUG] Name resolution...
[DEBUG] Desugaring...
[DEBUG] Disambiguating...
[DEBUG] Linting...
[DEBUG] - SCOPELANG -
[DEBUG] - DCALC -
[DEBUG] = SCOPELANG =
[DEBUG] = DCALC =
[DEBUG] Typechecking...
[DEBUG] Translating to default calculus...
[DEBUG] Typechecking again...
@ -52,21 +52,21 @@ f2 = λ (x: integer) →
```catala-test-inline
$ catala Interpret_Lcalc -s RentComputation --avoid_exceptions --optimize --debug
[DEBUG] - INIT -
[DEBUG] - SURFACE -
[DEBUG] = INIT =
[DEBUG] = SURFACE =
[DEBUG] Parsing scope_call4.catala_en
[DEBUG] - DESUGARED -
[DEBUG] = DESUGARED =
[DEBUG] Name resolution...
[DEBUG] Desugaring...
[DEBUG] Disambiguating...
[DEBUG] Linting...
[DEBUG] - SCOPELANG -
[DEBUG] - DCALC -
[DEBUG] = SCOPELANG =
[DEBUG] = DCALC =
[DEBUG] Typechecking...
[DEBUG] Translating to default calculus...
[DEBUG] Optimizing default calculus...
[DEBUG] Typechecking again...
[DEBUG] - LCALC -
[DEBUG] = LCALC =
[DEBUG] Optimizing lambda calculus...
[DEBUG] Starting interpretation...
[DEBUG] End of interpretation