Select colors for Uids upon instanciation

This way different Uid kinds will have a consistent color across error messages,
AST dumps, etc.

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
+module Gen_qualified (S : Style) () = struct
-  include Make (QualifiedMarkedString) ()
+  include Make (QualifiedMarkedString) (S) ()
 
   let fresh path t = fresh (path, t)
   let path t = fst (get_info t)

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

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} *)
 

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 @{<yellow>\"%a\"@}, the variable @{<yellow>\"%a\"@} is \
+              "In scope \"%a\", the variable \"%a\" is declared but never \
-               declared but never defined; did you forget something?"
+               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 @{<yellow>\"%a\"@} is never used; maybe it's \
+          "The structure \"%a\" is never used; maybe it's unnecessary?"
-           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 \
+                "The field \"%a\" of struct @{<yellow>\"%a\"@} is never used; \
-                 never used; maybe it's unnecessary?"
+                 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 \
+          "The enumeration \"%a\" is never used; maybe it's unnecessary?"
-           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 \
+                "The constructor \"%a\" of enumeration \"%a\" is never used; \
-                 @{<yellow>\"%a\"@} is never used; maybe it's unnecessary?"
+                 maybe it's unnecessary?"
                 EnumConstructor.format constructor EnumName.format e_name)
           constructors)
     p.program_ctx.ctx_enums

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 "@{<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 \
+    "Printing the tree of exceptions for the definitions of variable \"%a\" of \
-     @{<yellow>\"%a\"@} of scope @{<yellow>\"%a\"@}."
+     scope \"%a\"."
     Ast.ScopeDef.format var ScopeName.format scope;
   Dependency.ExceptionsDependencies.iter_vertex
     (fun ex ->
-      Message.emit_result
+      Message.emit_result "@[<v>Definitions with label \"%a\":@,%a@]"
-        "@[<v>Definitions with label @{<yellow>\"%a\"@}:@,%a@]" LabelName.format
+        LabelName.format ex.Dependency.ExceptionVertex.label
-        ex.Dependency.ExceptionVertex.label
         (RuleName.Map.format_values Pos.format_loc_text)
         ex.Dependency.ExceptionVertex.rules)
     g;

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 "@{<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
 
@@ -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 ()

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)

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 "@[<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))

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 ScopeName =
-module StructName = Uid.Gen_qualified ()
+  Uid.Gen_qualified
-module StructField = Uid.Gen ()
+    (struct
-module EnumName = Uid.Gen_qualified ()
+      let style = Ocolor_types.(Fg (C4 hi_magenta))
-module EnumConstructor = Uid.Gen ()
+    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 RuleName =
-module LabelName = Uid.Gen ()
+  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 ScopeVar =
-module SubScopeName = Uid.Gen ()
+  Uid.Gen
-module StateName = 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} *)
 

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 "@{<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

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

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

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] = INIT =
-[DEBUG] - SURFACE -
+[DEBUG] = SURFACE =
 [DEBUG] Parsing scope_call3.catala_en
-[DEBUG] - DESUGARED -
+[DEBUG] = DESUGARED =
 [DEBUG] Name resolution...
 [DEBUG] Desugaring...
 [DEBUG] Disambiguating...
 [DEBUG] Linting...
-[DEBUG] - SCOPELANG -
+[DEBUG] = SCOPELANG =
-[DEBUG] - DCALC -
+[DEBUG] = DCALC =
 [DEBUG] Typechecking...
 [DEBUG] Translating to default calculus...
 [DEBUG] Typechecking again...

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] = INIT =
-[DEBUG] - SURFACE -
+[DEBUG] = SURFACE =
 [DEBUG] Parsing scope_call4.catala_en
-[DEBUG] - DESUGARED -
+[DEBUG] = DESUGARED =
 [DEBUG] Name resolution...
 [DEBUG] Desugaring...
 [DEBUG] Disambiguating...
 [DEBUG] Linting...
-[DEBUG] - SCOPELANG -
+[DEBUG] = SCOPELANG =
-[DEBUG] - DCALC -
+[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] = INIT =
-[DEBUG] - SURFACE -
+[DEBUG] = SURFACE =
 [DEBUG] Parsing scope_call4.catala_en
-[DEBUG] - DESUGARED -
+[DEBUG] = DESUGARED =
 [DEBUG] Name resolution...
 [DEBUG] Desugaring...
 [DEBUG] Disambiguating...
 [DEBUG] Linting...
-[DEBUG] - SCOPELANG -
+[DEBUG] = SCOPELANG =
-[DEBUG] - DCALC -
+[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