Fix hashing of submodule references

compiler/catala_utils/uid.ml

@@ -114,12 +114,14 @@ module Path = struct
   let equal = List.equal Module.equal
   let compare = List.compare Module.compare
 
-  let rec strip n p =
+  let strip prefix p0 =
-    if n = 0 then p
+    let rec aux prefix p =
-    else
+      match prefix, p with
-      match p with
+      | pfx1 :: pfx, p1 :: p -> if Module.equal pfx1 p1 then aux pfx p else p0
-      | _ :: p -> strip (n - 1) p
+      | [], p -> p
-      | [] -> invalid_arg "Uid.Path.strip"
+      | _ -> p0
+    in
+    aux prefix p0
 end
 
 module QualifiedMarkedString = struct

compiler/catala_utils/uid.mli

@@ -90,6 +90,10 @@ module Path : sig
   val format : Format.formatter -> t -> unit
   val equal : t -> t -> bool
   val compare : t -> t -> int
+
+  val strip : t -> t -> t
+  (** [strip pfx p] removed [pfx] from the start of [p]. if [p] doesn't start
+      with [pfx], it is returned unchanged *)
 end
 
 (** Same as [Gen] but also registers path information *)
@@ -99,7 +103,6 @@ module Gen_qualified (_ : Style) () : sig
   val fresh : Path.t -> MarkedString.info -> t
   val path : t -> Path.t
   val get_info : t -> MarkedString.info
-  val hash : strip:int -> t -> Hash.t
+  val hash : strip:Path.t -> t -> Hash.t
-  (* [strip] strips that number of elements from the start of the path before
+  (* [strip] strips that prefix from the start of the path before hashing *)
-     hashing *)
 end

compiler/desugared/ast.ml

@@ -71,13 +71,17 @@ module ScopeDef = struct
       ScopeVar.format ppf (Mark.remove v);
       format_kind ppf k
 
-    let hash_kind = function
+    open Hash.Op
-      | Var None -> Hashtbl.hash `VarNone
-      | Var (Some st) -> Hashtbl.hash (`VarSome (StateName.id st))
-      | SubScopeInput { var_within_origin_scope = v; _ } ->
-        Hashtbl.hash (`SubScopeInput (ScopeVar.id v))
 
-    let hash (v, k) = Hashtbl.hash (ScopeVar.id (Mark.remove v), hash_kind k)
+    let hash_kind ~strip = function
+      | Var v -> !`Var % Hash.option StateName.hash v
+      | SubScopeInput { name; var_within_origin_scope } ->
+        !`SubScopeInput
+        % ScopeName.hash ~strip name
+        % ScopeVar.hash var_within_origin_scope
+
+    let hash ~strip (v, k) =
+      Hash.Op.(ScopeVar.hash (Mark.remove v) % hash_kind ~strip k)
   end
 
   include Base
@@ -288,24 +292,16 @@ module Hash = struct
     % !(d.scope_def_is_condition : bool)
     % io d.scope_def_io
 
-  let scope_def ~strip (var, kind) =
-    ScopeVar.hash (Mark.remove var)
-    %
-    match kind with
-    | ScopeDef.Var st -> Hash.option StateName.hash st
-    | ScopeDef.SubScopeInput { name; var_within_origin_scope } ->
-      ScopeName.hash ~strip name % ScopeVar.hash var_within_origin_scope
-
   let scope ~strip s =
     Hash.map ScopeVar.Map.fold ScopeVar.hash var_or_state s.scope_vars
     % Hash.map ScopeVar.Map.fold ScopeVar.hash (ScopeName.hash ~strip)
         s.scope_sub_scopes
     % ScopeName.hash ~strip s.scope_uid
-    % Hash.map ScopeDef.Map.fold (scope_def ~strip) (scope_decl ~strip)
+    % Hash.map ScopeDef.Map.fold (ScopeDef.hash ~strip) (scope_decl ~strip)
         s.scope_defs
   (* assertions, options, etc. are not expected to be part of interfaces *)
 
-  let modul ?(strip = 0) m =
+  let modul ?(strip = []) m =
     Hash.map ScopeName.Map.fold (ScopeName.hash ~strip) (scope ~strip)
       (ScopeName.Map.filter
          (fun _ s -> s.scope_visibility = Public)
@@ -316,8 +312,8 @@ module Hash = struct
            (fun _ td -> td.topdef_visibility = Public)
            m.module_topdefs)
 
-  let module_binding ?(root = false) modname m =
+  let module_binding modname m =
-    ModuleName.hash modname % modul ~strip:(if root then 0 else 1) m
+    ModuleName.hash modname % modul ~strip:[modname] m
 end
 
 let rec locations_used e : LocationSet.t =

compiler/desugared/ast.mli

@@ -32,7 +32,7 @@ module ScopeDef : sig
   val equal_kind : kind -> kind -> bool
   val compare_kind : kind -> kind -> int
   val format_kind : Format.formatter -> kind -> unit
-  val hash_kind : kind -> int
+  val hash_kind : strip:Uid.Path.t -> kind -> Hash.t
 
   type t = ScopeVar.t Mark.pos * kind
 
@@ -40,7 +40,7 @@ module ScopeDef : sig
   val compare : t -> t -> int
   val get_position : t -> Pos.t
   val format : Format.formatter -> t -> unit
-  val hash : t -> int
+  val hash : strip:Uid.Path.t -> t -> Hash.t
 
   module Map : Map.S with type key = t
   module Set : Set.S with type elt = t
@@ -154,11 +154,9 @@ module Hash : sig
   (** The [strip] argument below strips as many leading path components before
       hashing *)
 
-  val scope : strip:int -> scope -> Hash.t
+  val scope : strip:Uid.Path.t -> scope -> Hash.t
-  val modul : ?strip:int -> modul -> Hash.t
+  val modul : ?strip:Uid.Path.t -> modul -> Hash.t
-
+  val module_binding : ModuleName.t -> modul -> Hash.t
-  val module_binding : ?root:bool -> ModuleName.t -> modul -> Hash.t
-  (** This strips 1 path component by default unless [root] is [true] *)
 end
 
 (** {1 Helpers} *)

compiler/desugared/from_surface.ml

@@ -1703,19 +1703,20 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) :
     ModuleName.Map.mapi
       (fun mname mctx ->
         let m =
-        {
+          {
-          Ast.module_scopes = get_scopes mctx;
+            Ast.module_scopes = get_scopes mctx;
-          Ast.module_topdefs =
+            Ast.module_topdefs =
-            Ident.Map.fold
+              Ident.Map.fold
-              (fun _ name acc ->
+                (fun _ name acc ->
-                let topdef_type, topdef_visibility =
+                  let topdef_type, topdef_visibility =
-                  TopdefName.Map.find name ctxt.Name_resolution.topdefs
+                    TopdefName.Map.find name ctxt.Name_resolution.topdefs
-                in
+                  in
-                TopdefName.Map.add name
+                  TopdefName.Map.add name
-                  { Ast.topdef_expr = None; topdef_visibility; topdef_type }
+                    { Ast.topdef_expr = None; topdef_visibility; topdef_type }
-                  acc)
+                    acc)
-              mctx.topdefs TopdefName.Map.empty;
+                mctx.topdefs TopdefName.Map.empty;
-        } in
+          }
+        in
         m, Ast.Hash.module_binding mname m)
       ctxt.modules
   in
@@ -1816,7 +1817,5 @@ let translate_program (ctxt : Name_resolution.context) (surface : S.program) :
       (desugared.Ast.program_module_name
       |> Option.map
          @@ fun (mname, _) ->
-         ( mname,
+         mname, Ast.Hash.module_binding mname desugared.Ast.program_root);
-           Ast.Hash.module_binding ~root:true mname desugared.Ast.program_root )
-      );
   }

compiler/shared_ast/type.mli

@@ -26,8 +26,8 @@ val equal : t -> t -> bool
 val equal_list : t list -> t list -> bool
 val compare : t -> t -> int
 
-val hash : strip:int -> t -> Hash.t
+val hash : strip:Uid.Path.t -> t -> Hash.t
-(** The [strip] argument strips as many leading path components in included
+(** The [strip] argument strips the given leading path components in included
     identifiers before hashing *)
 
 val unifiable : t -> t -> bool