Propagate surface's scopecall binders position (#792)

compiler/dcalc/from_scopelang.ml

@@ -231,7 +231,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
               | _ -> assert false
             in
             Some (var_ctx.scope_input_name, v)
-          | Some var_ctx, Some e ->
+          | Some var_ctx, Some (_p, e) ->
             Some (var_ctx.scope_input_name, translate_expr ctx e)
           | Some var_ctx, None ->
             Message.error ~pos
@@ -242,7 +242,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
                 ]
               "Definition of input variable '%a' missing in this scope call"
               ScopeVar.format var_name
-          | None, Some e ->
+          | None, Some (_p, e) ->
             Message.error
               ~suggestion:
                 (List.map ScopeVar.to_string

compiler/desugared/from_surface.ml

@@ -221,6 +221,10 @@ let rec check_formula (op, pos_op) e =
     check_formula (op1, pos_op1) e2
   | _ -> ()
 
+(** Helper that restores surface positions in module paths. *)
+let restore_position path_item mname =
+  ModuleName.map_info (fun (mn, _) -> mn, Mark.get path_item) mname
+
 (** Usage: [translate_expr scope ctxt naked_expr]
 
     Translates [expr] into its desugared equivalent. [scope] is used to
@@ -479,7 +483,7 @@ let rec translate_expr
       "Access to intermediate states is only allowed for variables of the \
        current scope."
   | Ident (path, name, None) -> (
-    let ctxt = Name_resolution.module_ctx ctxt path in
+    let _, ctxt = Name_resolution.module_ctx ctxt path in
     match Ident.Map.find_opt (Mark.remove name) ctxt.local.topdefs with
     | Some v ->
       Expr.elocation
@@ -522,8 +526,14 @@ let rec translate_expr
     if scope = None then
       Message.error ~pos "Scope calls are not allowed outside of a scope.";
     let called_scope, scope_def =
-      let ctxt = Name_resolution.module_ctx ctxt path in
-      let uid = Name_resolution.get_scope ctxt id in
+      let resolved_path, ctxt = Name_resolution.module_ctx ctxt path in
+      let uid =
+        let uid = Name_resolution.get_scope ctxt id in
+        (* Retain the correct positions *)
+        ScopeName.map_info
+          (fun (_ml, pos) -> List.map2 restore_position path resolved_path, pos)
+          uid
+      in
       uid, ScopeName.Map.find uid ctxt.scopes
     in
     let in_struct =
@@ -549,7 +559,7 @@ let rec translate_expr
           in
           ScopeVar.Map.update var
             (function
-              | None -> Some (rec_helper e)
+              | None -> Some (Mark.get fld_id, rec_helper e)
               | Some _ ->
                 Message.error ~pos:(Mark.get fld_id)
                   "Duplicate definition of scope input variable '%a'."
@@ -585,14 +595,16 @@ let rec translate_expr
     in
     Expr.edstructamend ~fields ~e:(rec_helper e) ~name_opt:None emark
   | StructLit (((path, s_name), _), fields) ->
-    let ctxt = Name_resolution.module_ctx ctxt path in
+    let resolved_path, ctxt = Name_resolution.module_ctx ctxt path in
     let s_uid =
       match Ident.Map.find_opt (Mark.remove s_name) ctxt.local.typedefs with
       | Some (Name_resolution.TStruct s_uid)
       | Some (Name_resolution.TScope (_, { out_struct_name = s_uid; _ })) ->
-        (* Retain the correct position *)
+        (* Retain the correct positions *)
         StructName.map_info
-          (fun (ml, (s, _pos)) -> ml, (s, Mark.get s_name))
+          (fun (_, (s, _pos)) ->
+            let path = List.map2 restore_position path resolved_path in
+            path, (s, Mark.get s_name))
           s_uid
       | _ ->
         Message.error ~pos:(Mark.get s_name)
@@ -690,13 +702,17 @@ let rec translate_expr
         | enum :: rpath -> List.rev rpath, enum
         | _ -> assert false
       in
-      let ctxt = Name_resolution.module_ctx ctxt path in
+      let resolved_path, ctxt = Name_resolution.module_ctx ctxt path in
       let possible_c_uids = get_possible_c_uids ctxt in
       (* The path has been qualified *)
       let e_uid =
-        Name_resolution.get_enum ctxt enum
-        |> (* Retain the correct position *)
-        EnumName.map_info (fun (s, (x, _pos)) -> s, (x, Mark.get enum))
+        let e_uid = Name_resolution.get_enum ctxt enum in
+        (* Retain the correct positions *)
+        EnumName.map_info
+          (fun (_, (x, _pos)) ->
+            let path = List.map2 restore_position path resolved_path in
+            path, (x, Mark.get enum))
+          e_uid
       in
       try
         let c_uid =

compiler/desugared/name_resolution.ml

@@ -67,7 +67,7 @@ type typedef =
   | TScope of ScopeName.t * scope_info  (** Implicitly defined output struct *)
 
 type module_context = {
-  path : Uid.Path.t;
+  current_module : ModuleName.t option;
   typedefs : typedef Ident.Map.t;
       (** Gathers the names of the scopes, structs and enums *)
   field_idmap : StructField.t StructName.Map.t Ident.Map.t;
@@ -234,14 +234,22 @@ let get_modname ctxt (id, pos) =
   | None -> Message.error ~pos "Module \"@{<blue>%s@}\" not found" id
   | Some modname -> modname
 
-let get_module_ctx ctxt id =
-  let modname = get_modname ctxt id in
+let get_module_ctx ctxt modname =
   { ctxt with local = ModuleName.Map.find modname ctxt.modules }
 
-let rec module_ctx ctxt path0 =
-  match path0 with
-  | [] -> ctxt
-  | mod_id :: path -> module_ctx (get_module_ctx ctxt mod_id) path
+let module_ctx ctxt path0 =
+  let rec loop acc ctxt = function
+    | [] -> List.rev acc, ctxt
+    | mod_id :: path ->
+      let modname = get_modname ctxt mod_id in
+      let ctxt = get_module_ctx ctxt modname in
+      loop (modname :: acc) ctxt path
+  in
+  loop [] ctxt path0
+
+let get_module_ctx ctxt id =
+  let modname = get_modname ctxt id in
+  get_module_ctx ctxt modname
 
 (** {1 Declarations pass} *)
 
@@ -276,7 +284,7 @@ let process_subscope_decl
   | None ->
     let sub_scope_uid = ScopeVar.fresh (name, name_pos) in
     let original_subscope_uid =
-      let ctxt = module_ctx ctxt path in
+      let _, ctxt = module_ctx ctxt path in
       get_scope ctxt subscope
     in
     let scope_ctxt =
@@ -322,19 +330,22 @@ let is_type_cond ((typ, _) : Surface.Ast.typ) =
 
 (** Process a basic type (all types except function types) *)
 let rec process_base_typ
+    ?(rev_named_path_acc = [])
     (ctxt : context)
     ((typ, typ_pos) : Surface.Ast.base_typ Mark.pos) : typ =
   match typ with
   | Surface.Ast.Condition -> TLit TBool, typ_pos
   | Surface.Ast.Data (Surface.Ast.Collection t) ->
     ( TArray
-        (process_base_typ ctxt (Surface.Ast.Data (Mark.remove t), Mark.get t)),
+        (process_base_typ ~rev_named_path_acc ctxt
+           (Surface.Ast.Data (Mark.remove t), Mark.get t)),
       typ_pos )
   | Surface.Ast.Data (Surface.Ast.TTuple tl) ->
     ( TTuple
         (List.map
            (fun t ->
-             process_base_typ ctxt (Surface.Ast.Data (Mark.remove t), Mark.get t))
+             process_base_typ ~rev_named_path_acc ctxt
+               (Surface.Ast.Data (Mark.remove t), Mark.get t))
            tl),
       typ_pos )
   | Surface.Ast.Data (Surface.Ast.Primitive prim) -> (
@@ -347,11 +358,19 @@ let rec process_base_typ
     | Surface.Ast.Boolean -> TLit TBool, typ_pos
     | Surface.Ast.Text -> raise_unsupported_feature "text type" typ_pos
     | Surface.Ast.Named ([], (ident, _pos)) -> (
+      let path = List.rev rev_named_path_acc in
       match Ident.Map.find_opt ident ctxt.local.typedefs with
-      | Some (TStruct s_uid) -> TStruct s_uid, typ_pos
-      | Some (TEnum e_uid) -> TEnum e_uid, typ_pos
+      | Some (TStruct s_uid) ->
+        let s_uid = StructName.map_info (fun (_, x) -> path, x) s_uid in
+        TStruct s_uid, typ_pos
+      | Some (TEnum e_uid) ->
+        let e_uid = EnumName.map_info (fun (_, x) -> path, x) e_uid in
+        TEnum e_uid, typ_pos
       | Some (TScope (_, scope_str)) ->
-        TStruct scope_str.out_struct_name, typ_pos
+        let s_uid =
+          StructName.map_info (fun (_, x) -> path, x) scope_str.out_struct_name
+        in
+        TStruct s_uid, typ_pos
       | None ->
         Message.error ~pos:typ_pos
           "Unknown type @{<yellow>\"%s\"@}, not a struct or enum previously \
@@ -364,7 +383,14 @@ let rec process_base_typ
           "This refers to module @{<blue>%s@}, which was not found" modul
       | Some mname ->
         let mod_ctxt = ModuleName.Map.find mname ctxt.modules in
-        process_base_typ
+        let rev_named_path_acc : Uid.Path.t =
+          match mod_ctxt.current_module with
+          | Some mname ->
+            ModuleName.map_info (fun (s, _) -> s, mpos) mname
+            :: rev_named_path_acc
+          | None -> rev_named_path_acc
+        in
+        process_base_typ ~rev_named_path_acc
           { ctxt with local = mod_ctxt }
           Surface.Ast.(Data (Primitive (Named (path, id))), typ_pos)))
 
@@ -703,6 +729,9 @@ let process_name_item
         ]
       "%s name @{<yellow>\"%s\"@} already defined" msg name
   in
+  let path =
+    match ctxt.local.current_module with None -> [] | Some p -> [p]
+  in
   match Mark.remove item with
   | ScopeDecl decl ->
     let name, pos = decl.scope_decl_name in
@@ -711,9 +740,9 @@ let process_name_item
       (fun use ->
         raise_already_defined_error (typedef_info use) name pos "scope")
       (Ident.Map.find_opt name ctxt.local.typedefs);
-    let scope_uid = ScopeName.fresh ctxt.local.path (name, pos) in
-    let in_struct_name = StructName.fresh ctxt.local.path (name ^ "_in", pos) in
-    let out_struct_name = StructName.fresh ctxt.local.path (name, pos) in
+    let scope_uid = ScopeName.fresh path (name, pos) in
+    let in_struct_name = StructName.fresh path (name ^ "_in", pos) in
+    let out_struct_name = StructName.fresh path (name, pos) in
     let typedefs =
       Ident.Map.add name
         (TScope
@@ -745,7 +774,7 @@ let process_name_item
       (fun use ->
         raise_already_defined_error (typedef_info use) name pos "struct")
       (Ident.Map.find_opt name ctxt.local.typedefs);
-    let s_uid = StructName.fresh ctxt.local.path sdecl.struct_decl_name in
+    let s_uid = StructName.fresh path sdecl.struct_decl_name in
     let typedefs =
       Ident.Map.add
         (Mark.remove sdecl.struct_decl_name)
@@ -758,7 +787,7 @@ let process_name_item
       (fun use ->
         raise_already_defined_error (typedef_info use) name pos "enum")
       (Ident.Map.find_opt name ctxt.local.typedefs);
-    let e_uid = EnumName.fresh ctxt.local.path edecl.enum_decl_name in
+    let e_uid = EnumName.fresh path edecl.enum_decl_name in
     let typedefs =
       Ident.Map.add
         (Mark.remove edecl.enum_decl_name)
@@ -770,7 +799,7 @@ let process_name_item
     let name, _ = def.topdef_name in
     let uid =
       match Ident.Map.find_opt name ctxt.local.topdefs with
-      | None -> TopdefName.fresh ctxt.local.path def.topdef_name
+      | None -> TopdefName.fresh path def.topdef_name
       | Some uid -> uid
       (* Topdef declaration may appear multiple times as long as their types
          match and only one contains an expression defining it *)
@@ -1020,7 +1049,7 @@ let process_use_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
 
 let empty_module_ctxt =
   {
-    path = [];
+    current_module = None;
     typedefs = Ident.Map.empty;
     field_idmap = Ident.Map.empty;
     constructor_idmap = Ident.Map.empty;
@@ -1059,7 +1088,7 @@ let form_context (surface, mod_uses) surface_modules : context =
                 {
                   ctxt.local with
                   used_modules = mod_uses;
-                  path = [m];
+                  current_module = Some m;
                   is_external = intf.Surface.Ast.intf_modname.module_external;
                 };
             }

compiler/desugared/name_resolution.mli

@@ -67,7 +67,7 @@ type typedef =
   | TScope of ScopeName.t * scope_info  (** Implicitly defined output struct *)
 
 type module_context = {
-  path : Uid.Path.t;
+  current_module : ModuleName.t option;
       (** The current path being processed. Used for generating the Uids. *)
   typedefs : typedef Ident.Map.t;
       (** Gathers the names of the scopes, structs and enums *)
@@ -174,7 +174,7 @@ val get_scope : context -> Ident.t Mark.pos -> ScopeName.t
 (** Find a scope definition from the typedefs, failing if there is none or it
     has a different kind *)
 
-val module_ctx : context -> Surface.Ast.path -> context
+val module_ctx : context -> Surface.Ast.path -> Uid.Path.t * context
 (** Returns the context corresponding to the given module path; raises a user
     error if the module is not found *)
 

compiler/scopelang/from_desugared.ml

@@ -132,7 +132,7 @@ let rec translate_expr (ctx : ctx) (e : D.expr) : untyped Ast.expr boxed =
     Expr.escopecall ~scope
       ~args:
         (ScopeVar.Map.fold
-           (fun v e args' ->
+           (fun v (p, e) args' ->
              let v' =
                match ScopeVar.Map.find v ctx.scope_var_mapping with
                | WholeVar v' -> v'
@@ -162,7 +162,7 @@ let rec translate_expr (ctx : ctx) (e : D.expr) : untyped Ast.expr boxed =
                | Some _ -> Expr.epuredefault e' m
                | None -> e'
              in
-             ScopeVar.Map.add v' e' args')
+             ScopeVar.Map.add v' (p, e') args')
            args ScopeVar.Map.empty)
       m
   | EApp { f; tys; args } -> (
@@ -696,7 +696,7 @@ let translate_rule
           scope.scope_defs ScopeVar.Map.empty
       in
       let subscope_param_map =
-        ScopeVar.Map.map (fun (_, _, _, expr) -> expr) subscope_params
+        ScopeVar.Map.map (fun (_, p, _, expr) -> p, expr) subscope_params
       in
       let subscope_expr =
         Expr.escopecall ~scope:subscope ~args:subscope_param_map

compiler/shared_ast/definitions.ml

@@ -565,7 +565,8 @@ and ('a, 'b, 'm) base_gexpr =
   | ELocation : 'b glocation -> ('a, (< .. > as 'b), 'm) base_gexpr
   | EScopeCall : {
       scope : ScopeName.t;
-      args : ('a, 'm) gexpr ScopeVar.Map.t;
+      args : (Pos.t * ('a, 'm) gexpr) ScopeVar.Map.t;
+          (* Map elements contain their variable's surface position *)
     }
       -> ('a, < explicitScopes : yes ; .. >, 'm) base_gexpr
   | EDStructAmend : {