I/O plumbing necessary for this feature, missing main implem

compiler/catala_utils/cli.ml

@@ -22,6 +22,7 @@ type backend_option_builtin =
   | `Makefile
   | `Html
   | `Interpret
+  | `Interpret_Lcalc
   | `Typecheck
   | `OCaml
   | `Python
@@ -29,8 +30,8 @@ type backend_option_builtin =
   | `Lcalc
   | `Dcalc
   | `Scopelang
-  | `Proof
-  | `Interpret_Lcalc ]
+  | `Exceptions
+  | `Proof ]
 
 type 'a backend_option = [ backend_option_builtin | `Plugin of 'a ]
 
@@ -55,6 +56,7 @@ let backend_option_to_string = function
   | `Typecheck -> "Typecheck"
   | `Scalc -> "Scalc"
   | `Lcalc -> "Lcalc"
+  | `Exceptions -> "Exceptions"
   | `Plugin s -> s
 
 let backend_option_of_string backend =
@@ -72,6 +74,7 @@ let backend_option_of_string backend =
   | "typecheck" -> `Typecheck
   | "scalc" -> `Scalc
   | "lcalc" -> `Lcalc
+  | "exceptions" -> `Exceptions
   | s -> `Plugin s
 
 (** Source files to be compiled *)
@@ -234,6 +237,12 @@ let ex_scope =
     & opt (some string) None
     & info ["s"; "scope"] ~docv:"SCOPE" ~doc:"Scope to be focused on.")
 
+let ex_variable =
+  Arg.(
+    value
+    & opt (some string) None
+    & info ["v"; "variable"] ~docv:"VARIABLE" ~doc:"Variable to be focused on.")
+
 let output =
   Arg.(
     value
@@ -258,6 +267,7 @@ type options = {
   disable_counterexamples : bool;
   optimize : bool;
   ex_scope : string option;
+  ex_variable : string option;
   output_file : string option;
   closure_conversion : bool;
   print_only_law : bool;
@@ -280,6 +290,7 @@ let options =
       disable_counterexamples
       optimize
       ex_scope
+      ex_variable
       output_file
       print_only_law : options =
     {
@@ -296,6 +307,7 @@ let options =
       disable_counterexamples;
       optimize;
       ex_scope;
+      ex_variable;
       output_file;
       closure_conversion;
       print_only_law;
@@ -318,6 +330,7 @@ let options =
     $ disable_counterexamples_opt
     $ optimize
     $ ex_scope
+    $ ex_variable
     $ output
     $ print_only_law)
 
@@ -402,6 +415,13 @@ let info =
           "Prints a debugging verbatim of the statement calculus intermediate \
            representation of the Catala program. Use the $(b,-s) option to \
            restrict the output to a particular scope." );
+      `I
+        ( "$(b,Exceptions)",
+          "Prints the exception tree for the definitions of a particular \
+           variable, for debugging purposes. Use the $(b,-s) option to select \
+           the scope and the $(b,-v) option to select the variable. Use \
+           foo.bar to access state bar of variable foo or variable bar of \
+           subscope foo." );
       `I
         ( "$(b,pygmentize)",
           "This special command is a wrapper around the $(b,pygmentize) \

compiler/catala_utils/cli.mli

@@ -30,6 +30,7 @@ type backend_option_builtin =
   | `Lcalc
   | `Dcalc
   | `Scopelang
+  | `Exceptions
   | `Proof ]
 
 type 'a backend_option = [ backend_option_builtin | `Plugin of 'a ]
@@ -105,6 +106,7 @@ type options = {
   disable_counterexamples : bool;
   optimize : bool;
   ex_scope : string option;
+  ex_variable : string option;
   output_file : string option;
   closure_conversion : bool;
   print_only_law : bool;

compiler/desugared/print.ml

@@ -0,0 +1,22 @@
+(* This file is part of the Catala compiler, a specification language for tax
+   and social benefits computation rules. Copyright (C) 2023 Inria, contributor:
+   Denis Merigoux <denis.merigoux@inria.fr>
+
+   Licensed under the Apache License, Version 2.0 (the "License"); you may not
+   use this file except in compliance with the License. You may obtain a copy of
+   the License at
+
+   http://www.apache.org/licenses/LICENSE-2.0
+
+   Unless required by applicable law or agreed to in writing, software
+   distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
+   WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
+   License for the specific language governing permissions and limitations under
+   the License. *)
+
+open Shared_ast
+
+let print_exceptions_graph
+    (var : DesugaredVarName.t)
+    (g : Dependency.ExceptionsDependencies.t) =
+  assert false

compiler/desugared/print.mli

@@ -0,0 +1,19 @@
+(* This file is part of the Catala compiler, a specification language for tax
+   and social benefits computation rules. Copyright (C) 2023 Inria, contributor:
+   Denis Merigoux <denis.merigoux@inria.fr>
+
+   Licensed under the Apache License, Version 2.0 (the "License"); you may not
+   use this file except in compliance with the License. You may obtain a copy of
+   the License at
+
+   http://www.apache.org/licenses/LICENSE-2.0
+
+   Unless required by applicable law or agreed to in writing, software
+   distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
+   WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
+   License for the specific language governing permissions and limitations under
+   the License. *)
+
+val print_exceptions_graph :
+  Shared_ast.DesugaredVarName.t -> Dependency.ExceptionsDependencies.t -> unit
+(** Prints the exception graph of a variable to the terminal *)

compiler/driver.ml

@@ -140,7 +140,8 @@ let driver source_file (options : Cli.options) : int =
                 language fmt (fun fmt -> weave_output fmt prgm)
           else weave_output fmt prgm)
     | ( `Interpret | `Interpret_Lcalc | `Typecheck | `OCaml | `Python | `Scalc
-      | `Lcalc | `Dcalc | `Scopelang | `Proof | `Plugin _ ) as backend -> (
+      | `Lcalc | `Dcalc | `Scopelang | `Exceptions | `Proof | `Plugin _ ) as
+      backend -> (
       Cli.debug_print "Name resolution...";
       let ctxt = Desugared.Name_resolution.form_context prgm in
       let scope_uid =
@@ -164,9 +165,108 @@ let driver source_file (options : Cli.options) : int =
           match Shared_ast.IdentName.Map.find_opt name ctxt.typedefs with
           | Some (Desugared.Name_resolution.TScope (uid, _)) -> uid
           | _ ->
-            Errors.raise_error "There is no scope \"%s\" inside the program."
+            Errors.raise_error "There is no scope \"%a\" inside the program."
+              (Cli.format_with_style [ANSITerminal.yellow])
               name)
       in
+      (* This uid is a Desugared identifier *)
+      let variable_uid =
+        match options.ex_variable, backend with
+        | None, `Exceptions ->
+          Errors.raise_error
+            "Please specify a variable with the -v option to print its \
+             exception tree."
+        | None, _ -> None
+        | Some name, _ -> (
+          (* Sometimes the variable selected is of the form [a.b]*)
+          let first_part, second_part =
+            match
+              Re.(
+                exec_opt
+                  (compile
+                  @@ whole_string
+                  @@ seq
+                       [
+                         group (rep1 (compl [char '.']));
+                         char '.';
+                         group (rep1 any);
+                       ])
+                  name)
+            with
+            | None -> name, None
+            | Some groups -> Re.Group.get groups 1, Some (Re.Group.get groups 2)
+          in
+          match
+            Shared_ast.IdentName.Map.find_opt first_part
+              (Shared_ast.ScopeName.Map.find scope_uid ctxt.scopes).var_idmap
+          with
+          | None ->
+            Errors.raise_error "Variable \"%a\" not found inside scope \"%a\""
+              (Cli.format_with_style [ANSITerminal.yellow])
+              name
+              (Cli.format_with_style [ANSITerminal.yellow])
+              (Format.asprintf "%a" Shared_ast.ScopeName.format_t scope_uid)
+          | Some
+              (Desugared.Name_resolution.SubScope
+                (subscope_var_name, subscope_name)) -> (
+            match second_part with
+            | None ->
+              Errors.raise_error
+                "Subscope \"%a\" of scope \"%a\" cannot be selected by itself, \
+                 please add \".<var>\" where <var> is a subscope variable."
+                (Cli.format_with_style [ANSITerminal.yellow])
+                (Format.asprintf "%a" Shared_ast.SubScopeName.format_t
+                   subscope_var_name)
+                (Cli.format_with_style [ANSITerminal.yellow])
+                (Format.asprintf "%a" Shared_ast.ScopeName.format_t scope_uid)
+            | Some second_part -> (
+              match
+                Shared_ast.IdentName.Map.find_opt second_part
+                  (Shared_ast.ScopeName.Map.find subscope_name ctxt.scopes)
+                    .var_idmap
+              with
+              | Some (Desugared.Name_resolution.ScopeVar v) ->
+                Some
+                  (Shared_ast.DesugaredVarName.SubScopeVar (subscope_var_name, v))
+              | _ ->
+                Errors.raise_error
+                  "Var \"%a\" of subscope \"%a\" in scope \"%a\" does not \
+                   exist, please check your command line arguments."
+                  (Cli.format_with_style [ANSITerminal.yellow])
+                  second_part
+                  (Cli.format_with_style [ANSITerminal.yellow])
+                  (Format.asprintf "%a" Shared_ast.SubScopeName.format_t
+                     subscope_var_name)
+                  (Cli.format_with_style [ANSITerminal.yellow])
+                  (Format.asprintf "%a" Shared_ast.ScopeName.format_t scope_uid)
+              ))
+          | Some (Desugared.Name_resolution.ScopeVar v) ->
+            Some
+              (Shared_ast.DesugaredVarName.ScopeVar
+                 ( v,
+                   Option.map
+                     (fun second_part ->
+                       let var_sig =
+                         Shared_ast.ScopeVar.Map.find v ctxt.var_typs
+                       in
+                       match
+                         Shared_ast.IdentName.Map.find_opt second_part
+                           var_sig.var_sig_states_idmap
+                       with
+                       | Some state -> state
+                       | None ->
+                         Errors.raise_error
+                           "State \"%a\" is not found for variable \"%a\" of \
+                            scope \"%a\""
+                           (Cli.format_with_style [ANSITerminal.yellow])
+                           second_part
+                           (Cli.format_with_style [ANSITerminal.yellow])
+                           first_part
+                           (Cli.format_with_style [ANSITerminal.yellow])
+                           (Format.asprintf "%a" Shared_ast.ScopeName.format_t
+                              scope_uid))
+                     second_part )))
+      in
       Cli.debug_print "Desugaring...";
       let prgm = Desugared.From_surface.translate_program ctxt prgm in
       Cli.debug_print "Disambiguating...";
@@ -174,8 +274,20 @@ let driver source_file (options : Cli.options) : int =
       Cli.debug_print "Linting...";
       Desugared.Linting.lint_program prgm;
       Cli.debug_print "Collecting rules...";
-      let prgm = Scopelang.From_desugared.translate_program prgm in
+      let prgm, exceptions_graphs =
+        Scopelang.From_desugared.translate_program prgm
+      in
       match backend with
+      | `Exceptions ->
+        let variable_uid =
+          match variable_uid with
+          | Some variable_uid -> variable_uid
+          | None ->
+            Errors.raise_error
+              "Please provide a scope variable to analyze with the -v option."
+        in
+        Desugared.Print.print_exceptions_graph variable_uid
+          (Shared_ast.DesugaredVarName.Map.find variable_uid exceptions_graphs)
       | `Scopelang ->
         let _output_file, with_output = get_output_format () in
         with_output

compiler/scopelang/from_desugared.ml

@@ -180,7 +180,8 @@ type rule_tree =
     priorities declared between rules *)
 let def_map_to_tree
     (def_info : Desugared.Ast.ScopeDef.t)
-    (def : Desugared.Ast.rule RuleName.Map.t) : rule_tree list =
+    (def : Desugared.Ast.rule RuleName.Map.t) :
+    rule_tree list * Desugared.Dependency.ExceptionsDependencies.t =
   let exc_graph = Desugared.Dependency.build_exceptions_graph def def_info in
   Desugared.Dependency.check_for_exception_cycle def exc_graph;
   (* we start by the base cases: they are the vertices which have no
@@ -207,7 +208,7 @@ let def_map_to_tree
     | [] -> Leaf base_case_as_rule_list
     | _ -> Node (List.map build_tree exceptions, base_case_as_rule_list)
   in
-  List.map build_tree base_cases
+  List.map build_tree base_cases, exc_graph
 
 (** From the {!type: rule_tree}, builds an {!constructor: Dcalc.EDefault}
     expression in the scope language. The [~toplevel] parameter is used to know
@@ -342,9 +343,10 @@ let translate_def
     (typ : typ)
     (io : Desugared.Ast.io)
     ~(is_cond : bool)
-    ~(is_subscope_var : bool) : untyped Ast.expr boxed =
+    ~(is_subscope_var : bool) :
+    untyped Ast.expr boxed * Desugared.Dependency.ExceptionsDependencies.t =
   (* Here, we have to transform this list of rules into a default tree. *)
-  let top_list = def_map_to_tree def_info def in
+  let top_list, exc_graph = def_map_to_tree def_info def in
   let is_input =
     match Marked.unmark io.Desugared.Ast.io_input with
     | OnlyInput -> true
@@ -397,34 +399,37 @@ let translate_def
     match params with
     | Some (ps, _) ->
       let labels, tys = List.split ps in
-      Expr.make_abs
-        (Array.of_list
-           (List.map (fun lbl -> Var.make (Marked.unmark lbl)) labels))
-        empty_error tys (Expr.mark_pos m)
-    | _ -> empty_error
+      ( Expr.make_abs
+          (Array.of_list
+             (List.map (fun lbl -> Var.make (Marked.unmark lbl)) labels))
+          empty_error tys (Expr.mark_pos m),
+        exc_graph )
+    | _ -> empty_error, exc_graph
   else
-    rule_tree_to_expr ~toplevel:true ~is_reentrant_var:is_reentrant ctx
-      (Desugared.Ast.ScopeDef.get_position def_info)
-      (Option.map
-         (fun (ps, _) ->
-           (List.map (fun (lbl, _) -> Var.make (Marked.unmark lbl))) ps)
-         params)
-      (match top_list, top_value with
-      | [], None ->
-        (* In this case, there are no rules to define the expression and no
-           default value so we put an empty rule. *)
-        Leaf [Desugared.Ast.empty_rule (Marked.get_mark typ) params]
-      | [], Some top_value ->
-        (* In this case, there are no rules to define the expression but a
-           default value so we put it. *)
-        Leaf [top_value]
-      | _, Some top_value ->
-        (* When there are rules + a default value, we put the rules as
-           exceptions to the default value *)
-        Node (top_list, [top_value])
-      | [top_tree], None -> top_tree
-      | _, None ->
-        Node (top_list, [Desugared.Ast.empty_rule (Marked.get_mark typ) params]))
+    ( rule_tree_to_expr ~toplevel:true ~is_reentrant_var:is_reentrant ctx
+        (Desugared.Ast.ScopeDef.get_position def_info)
+        (Option.map
+           (fun (ps, _) ->
+             (List.map (fun (lbl, _) -> Var.make (Marked.unmark lbl))) ps)
+           params)
+        (match top_list, top_value with
+        | [], None ->
+          (* In this case, there are no rules to define the expression and no
+             default value so we put an empty rule. *)
+          Leaf [Desugared.Ast.empty_rule (Marked.get_mark typ) params]
+        | [], Some top_value ->
+          (* In this case, there are no rules to define the expression but a
+             default value so we put it. *)
+          Leaf [top_value]
+        | _, Some top_value ->
+          (* When there are rules + a default value, we put the rules as
+             exceptions to the default value *)
+          Node (top_list, [top_value])
+        | [top_tree], None -> top_tree
+        | _, None ->
+          Node
+            (top_list, [Desugared.Ast.empty_rule (Marked.get_mark typ) params])),
+      exc_graph )
 
 let translate_rule ctx (scope : Desugared.Ast.scope) = function
   | Desugared.Dependency.Vertex.Var (var, state) -> (
@@ -449,10 +454,10 @@ let translate_rule ctx (scope : Desugared.Ast.scope) = function
              (RuleName.Map.bindings var_def))
         "It is impossible to give a definition to a scope variable tagged as \
          input."
-    | OnlyInput -> []
+    | OnlyInput -> [], DesugaredVarName.Map.empty
     (* we do not provide any definition for an input-only variable *)
     | _ ->
-      let expr_def =
+      let expr_def, exc_graph =
         translate_def ctx
           (Desugared.Ast.ScopeDef.Var (var, state))
           var_def var_params var_typ scope_def.Desugared.Ast.scope_def_io
@@ -464,15 +469,18 @@ let translate_rule ctx (scope : Desugared.Ast.scope) = function
         | States states, Some state -> List.assoc state states
         | _ -> failwith "should not happen"
       in
-      [
-        Ast.Definition
-          ( ( ScopelangScopeVar
-                (scope_var, Marked.get_mark (ScopeVar.get_info scope_var)),
-              Marked.get_mark (ScopeVar.get_info scope_var) ),
-            var_typ,
-            scope_def.Desugared.Ast.scope_def_io,
-            Expr.unbox expr_def );
-      ])
+      ( [
+          Ast.Definition
+            ( ( ScopelangScopeVar
+                  (scope_var, Marked.get_mark (ScopeVar.get_info scope_var)),
+                Marked.get_mark (ScopeVar.get_info scope_var) ),
+              var_typ,
+              scope_def.Desugared.Ast.scope_def_io,
+              Expr.unbox expr_def );
+        ],
+        DesugaredVarName.Map.singleton
+          (DesugaredVarName.ScopeVar (var, state))
+          exc_graph ))
   | Desugared.Dependency.Vertex.SubScope sub_scope_index ->
     (* Before calling the sub_scope, we need to include all the re-definitions
        of subscope parameters*)
@@ -539,7 +547,7 @@ let translate_rule ctx (scope : Desugared.Ast.scope) = function
             | _ -> ());
             (* Now that all is good, we can proceed with translating this
                redefinition to a proper Scopelang term. *)
-            let expr_def =
+            let expr_def, exc_graph =
               translate_def ctx def_key def scope_def.D.scope_def_parameters
                 def_typ scope_def.Desugared.Ast.scope_def_io ~is_cond
                 ~is_subscope_var:true
@@ -548,40 +556,53 @@ let translate_rule ctx (scope : Desugared.Ast.scope) = function
               SubScopeName.Map.find sub_scope_index scope.scope_sub_scopes
             in
             let var_pos = Desugared.Ast.ScopeDef.get_position def_key in
-            Ast.Definition
-              ( ( SubScopeVar
-                    ( subscop_real_name,
-                      (sub_scope_index, var_pos),
-                      match
-                        ScopeVar.Map.find sub_scope_var ctx.scope_var_mapping
-                      with
-                      | WholeVar v -> v, var_pos
-                      | States states ->
-                        (* When defining a sub-scope variable, we always define
-                           its first state in the sub-scope. *)
-                        snd (List.hd states), var_pos ),
-                  var_pos ),
-                def_typ,
-                scope_def.Desugared.Ast.scope_def_io,
-                Expr.unbox expr_def ))
+            ( Ast.Definition
+                ( ( SubScopeVar
+                      ( subscop_real_name,
+                        (sub_scope_index, var_pos),
+                        match
+                          ScopeVar.Map.find sub_scope_var ctx.scope_var_mapping
+                        with
+                        | WholeVar v -> v, var_pos
+                        | States states ->
+                          (* When defining a sub-scope variable, we always
+                             define its first state in the sub-scope. *)
+                          snd (List.hd states), var_pos ),
+                    var_pos ),
+                  def_typ,
+                  scope_def.Desugared.Ast.scope_def_io,
+                  Expr.unbox expr_def ),
+              (exc_graph, sub_scope_var) ))
         sub_scope_vars_redefs_candidates
     in
-    let sub_scope_vars_redefs =
+    let sub_scope_vars_redefs_and_exc_graphs =
       List.map snd (Desugared.Ast.ScopeDefMap.bindings sub_scope_vars_redefs)
     in
-    sub_scope_vars_redefs
-    @ [
-        Ast.Call
-          ( sub_scope,
-            sub_scope_index,
-            Untyped
-              { pos = Marked.get_mark (SubScopeName.get_info sub_scope_index) }
-          );
-      ]
+    let sub_scope_vars_redefs =
+      List.map fst sub_scope_vars_redefs_and_exc_graphs
+    in
+    ( sub_scope_vars_redefs
+      @ [
+          Ast.Call
+            ( sub_scope,
+              sub_scope_index,
+              Untyped
+                {
+                  pos = Marked.get_mark (SubScopeName.get_info sub_scope_index);
+                } );
+        ],
+      List.fold_left
+        (fun exc_graphs (new_exc_graph, subscope_var) ->
+          DesugaredVarName.Map.add
+            (DesugaredVarName.SubScopeVar (sub_scope_index, subscope_var))
+            new_exc_graph exc_graphs)
+        DesugaredVarName.Map.empty
+        (List.map snd sub_scope_vars_redefs_and_exc_graphs) )
 
 (** Translates a scope *)
 let translate_scope (ctx : ctx) (scope : Desugared.Ast.scope) :
-    untyped Ast.scope_decl =
+    untyped Ast.scope_decl
+    * Desugared.Dependency.ExceptionsDependencies.t DesugaredVarName.Map.t =
   let scope_dependencies =
     Desugared.Dependency.build_scope_dependencies scope
   in
@@ -589,8 +610,18 @@ let translate_scope (ctx : ctx) (scope : Desugared.Ast.scope) :
   let scope_ordering =
     Desugared.Dependency.correct_computation_ordering scope_dependencies
   in
-  let scope_decl_rules =
-    List.flatten (List.map (translate_rule ctx scope) scope_ordering)
+  let scope_decl_rules, exceptions_graphs =
+    List.fold_left
+      (fun (scope_decl_rules, exceptions_graphs) scope_def_key ->
+        let new_rules, new_exceptions_graphs =
+          translate_rule ctx scope scope_def_key
+        in
+        ( scope_decl_rules @ new_rules,
+          DesugaredVarName.Map.union
+            (fun _ _ _ -> assert false (* there should not be key conflicts *))
+            new_exceptions_graphs exceptions_graphs ))
+      ([], DesugaredVarName.Map.empty)
+      scope_ordering
   in
   (* Then, after having computed all the scopes variables, we add the
      assertions. TODO: the assertions should be interleaved with the
@@ -641,17 +672,20 @@ let translate_scope (ctx : ctx) (scope : Desugared.Ast.scope) :
       scope.scope_vars ScopeVar.Map.empty
   in
   let pos = Marked.get_mark (ScopeName.get_info scope.scope_uid) in
-  {
-    Ast.scope_decl_name = scope.scope_uid;
-    Ast.scope_decl_rules;
-    Ast.scope_sig;
-    Ast.scope_mark = Untyped { pos };
-    Ast.scope_options = scope.scope_options;
-  }
+  ( {
+      Ast.scope_decl_name = scope.scope_uid;
+      Ast.scope_decl_rules;
+      Ast.scope_sig;
+      Ast.scope_mark = Untyped { pos };
+      Ast.scope_options = scope.scope_options;
+    },
+    exceptions_graphs )
 
 (** {1 API} *)
 
-let translate_program (pgrm : Desugared.Ast.program) : untyped Ast.program =
+let translate_program (pgrm : Desugared.Ast.program) :
+    untyped Ast.program
+    * Desugared.Dependency.ExceptionsDependencies.t DesugaredVarName.Map.t =
   (* First we give mappings to all the locations between Desugared and This
      involves creating a new Scopelang scope variable for every state of a
      Desugared variable. *)
@@ -706,12 +740,25 @@ let translate_program (pgrm : Desugared.Ast.program) : untyped Ast.program =
         { out_str with out_struct_fields })
       pgrm.Desugared.Ast.program_ctx.ctx_scopes
   in
-  {
-    Ast.program_topdefs =
-      TopdefName.Map.map
-        (fun (e, ty) -> Expr.unbox (translate_expr ctx e), ty)
-        pgrm.program_topdefs;
-    Ast.program_scopes =
-      ScopeName.Map.map (translate_scope ctx) pgrm.program_scopes;
-    program_ctx = { pgrm.program_ctx with ctx_scopes };
-  }
+  let new_program_scopes, exceptions_graphs =
+    ScopeName.Map.fold
+      (fun scope_name scope (new_program_scopes, exceptions_graph) ->
+        let new_program_scope, new_exceptions_graphs =
+          translate_scope ctx scope
+        in
+        ( ScopeName.Map.add scope_name new_program_scope new_program_scopes,
+          DesugaredVarName.Map.union
+            (fun _ _ _ -> assert false (* key conflicts should not happen*))
+            new_exceptions_graphs exceptions_graph ))
+      pgrm.program_scopes
+      (ScopeName.Map.empty, DesugaredVarName.Map.empty)
+  in
+  ( {
+      Ast.program_topdefs =
+        TopdefName.Map.map
+          (fun (e, ty) -> Expr.unbox (translate_expr ctx e), ty)
+          pgrm.program_topdefs;
+      Ast.program_scopes = new_program_scopes;
+      program_ctx = { pgrm.program_ctx with ctx_scopes };
+    },
+    exceptions_graphs )

compiler/scopelang/from_desugared.mli

@@ -16,4 +16,10 @@
 
 (** Translation from {!module: Desugared.Ast} to {!module: Scopelang.Ast} *)
 
-val translate_program : Desugared.Ast.program -> Shared_ast.untyped Ast.program
+val translate_program :
+  Desugared.Ast.program ->
+  Shared_ast.untyped Ast.program
+  * Desugared.Dependency.ExceptionsDependencies.t
+    Shared_ast.DesugaredVarName.Map.t
+(** This functions returns the translated program as well as all the graphs of
+    exceptions inferred for each scope variable of the program. *)

compiler/shared_ast/definitions.ml

@@ -45,6 +45,58 @@ module SubScopeName = Uid.Gen ()
 module StateName = Uid.Gen ()
 
 (** {1 Abstract syntax tree} *)
+module DesugaredVarName : sig
+  type t =
+    | ScopeVar of ScopeVar.t * StateName.t option
+    | SubScopeVar of SubScopeName.t * ScopeVar.t
+
+  val hash : t -> int
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+
+  module Map : Map.S with type key = t
+  module Set : Set.S with type elt = t
+end = struct
+  module Ordering = struct
+    type t =
+      | ScopeVar of ScopeVar.t * StateName.t option
+      | SubScopeVar of SubScopeName.t * ScopeVar.t
+
+    let hash x =
+      match x with
+      | ScopeVar (x, None) -> ScopeVar.hash x
+      | ScopeVar (x, Some sx) ->
+        Int.logxor (ScopeVar.hash x) (StateName.hash sx)
+      | SubScopeVar (x, y) -> Int.logxor (SubScopeName.hash x) (ScopeVar.hash y)
+
+    let compare x y =
+      match x, y with
+      | ScopeVar (x, xst), ScopeVar (y, yst) -> (
+        match ScopeVar.compare x y with
+        | 0 -> Option.compare StateName.compare xst yst
+        | n -> n)
+      | SubScopeVar (x, xv), SubScopeVar (y, yv) -> (
+        match SubScopeName.compare x y with
+        | 0 -> ScopeVar.compare xv yv
+        | n -> n)
+      | ScopeVar _, _ -> -1
+      | _, ScopeVar _ -> 1
+      | SubScopeVar _, _ -> .
+      | _, SubScopeVar _ -> .
+
+    let equal x y =
+      match x, y with
+      | ScopeVar (x, sx), ScopeVar (y, sy) ->
+        ScopeVar.equal x y && Option.equal StateName.equal sx sy
+      | SubScopeVar (x, xv), SubScopeVar (y, yv) ->
+        SubScopeName.equal x y && ScopeVar.equal xv yv
+      | (ScopeVar _ | SubScopeVar _), _ -> false
+  end
+
+  include Ordering
+  module Map = Map.Make (Ordering)
+  module Set = Set.Make (Ordering)
+end
 
 (** Define a common base type for the expressions in most passes of the compiler *)