diff --git a/compiler/catala_utils/uid.ml b/compiler/catala_utils/uid.ml index 451b4db6..bf16849f 100644 --- a/compiler/catala_utils/uid.ml +++ b/compiler/catala_utils/uid.ml @@ -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) diff --git a/compiler/catala_utils/uid.mli b/compiler/catala_utils/uid.mli index ef59e552..3eef6b77 100644 --- a/compiler/catala_utils/uid.mli +++ b/compiler/catala_utils/uid.mli @@ -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 diff --git a/compiler/desugared/ast.ml b/compiler/desugared/ast.ml index 1ef669eb..1dfa6b0f 100644 --- a/compiler/desugared/ast.ml +++ b/compiler/desugared/ast.ml @@ -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} *) diff --git a/compiler/desugared/linting.ml b/compiler/desugared/linting.ml index 5258f124..53271445 100644 --- a/compiler/desugared/linting.ml +++ b/compiler/desugared/linting.ml @@ -35,8 +35,8 @@ let detect_empty_definitions (p : program) : unit = then Message.emit_spanned_warning (ScopeDef.get_position scope_def_key) - "In scope @{\"%a\"@}, the variable @{\"%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 @@ -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 @{\"%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 @{\"%a\"@} of struct @{\"%a\"@} is \ - never used; maybe it's unnecessary?" + "The field \"%a\" of struct @{\"%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 @{\"%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 @{\"%a\"@} of enumeration \ - @{\"%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 diff --git a/compiler/desugared/print.ml b/compiler/desugared/print.ml index aaa185f9..208a9a0a 100644 --- a/compiler/desugared/print.ml +++ b/compiler/desugared/print.ml @@ -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 "@{\"%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 \ - @{\"%a\"@} of scope @{\"%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 - "@[Definitions with label @{\"%a\"@}:@,%a@]" LabelName.format - ex.Dependency.ExceptionVertex.label + Message.emit_result "@[Definitions with label \"%a\":@,%a@]" + LabelName.format ex.Dependency.ExceptionVertex.label (RuleName.Map.format_values Pos.format_loc_text) ex.Dependency.ExceptionVertex.rules) g; diff --git a/compiler/driver.ml b/compiler/driver.ml index d90c22a6..b04d4500 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -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 "@{=@} @{%s@} @{=@}" + (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 @@ -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 () diff --git a/compiler/scalc/ast.ml b/compiler/scalc/ast.ml index 0c3070e5..e75b2845 100644 --- a/compiler/scalc/ast.ml +++ b/compiler/scalc/ast.ml @@ -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) diff --git a/compiler/scalc/print.ml b/compiler/scalc/print.ml index 9e8bece1..24ffdb39 100644 --- a/compiler/scalc/print.ml +++ b/compiler/scalc/print.ml @@ -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 "@[%a@ %a@]" Print.enum_constructor cons + Format.fprintf fmt "@[%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 @[%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)) diff --git a/compiler/shared_ast/definitions.ml b/compiler/shared_ast/definitions.ml index ce0b84a2..5af08d69 100644 --- a/compiler/shared_ast/definitions.ml +++ b/compiler/shared_ast/definitions.ml @@ -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} *) diff --git a/compiler/shared_ast/print.ml b/compiler/shared_ast/print.ml index 185ddad4..fad413b4 100644 --- a/compiler/shared_ast/print.ml +++ b/compiler/shared_ast/print.ml @@ -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 "@{%a@}" ModuleName.format m - -let path ppf p = - Format.pp_print_list - ~pp_sep:(fun _ () -> ()) - (fun ppf m -> - Format.fprintf ppf "%a@{.@}" 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 "@{%a@}" EnumConstructor.format c - -let struct_field (fmt : Format.formatter) (c : StructField.t) : unit = - Format.fprintf fmt "@{%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 "@[%a%a@,%a@]" (lhs exprc) e punctuation "." - struct_field field + StructField.format field | EInj { e; cons; _ } -> Format.fprintf fmt "@[%a@ %a@]" EnumConstructor.format cons (rhs exprc) e diff --git a/compiler/shared_ast/print.mli b/compiler/shared_ast/print.mli index cbab2799..becd837b 100644 --- a/compiler/shared_ast/print.mli +++ b/compiler/shared_ast/print.mli @@ -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 diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index 7bc9e6f1..00985041 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -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 diff --git a/tests/test_scope/good/scope_call3.catala_en b/tests/test_scope/good/scope_call3.catala_en index 149b006a..5171bae1 100644 --- a/tests/test_scope/good/scope_call3.catala_en +++ b/tests/test_scope/good/scope_call3.catala_en @@ -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... diff --git a/tests/test_scope/good/scope_call4.catala_en b/tests/test_scope/good/scope_call4.catala_en index f2dddf16..7e7dbc21 100644 --- a/tests/test_scope/good/scope_call4.catala_en +++ b/tests/test_scope/good/scope_call4.catala_en @@ -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