Add locations to toplevel directives

Changes

@@ -143,6 +143,9 @@ Working version
   (Xavier Clerc, review by Gabriel Scherer, Sébastien Hinderer, and
    Xavier Leroy)
 
+- GPR#1954: Add locations to toplevel directives.
+  (Hugo Heuzard, review by Gabriel Radanne)
+
 ### Code generation and optimizations:
 
 - MPR#7725, GPR#1754: improve AFL instrumentation for objects and lazy values.

parsing/depend.ml

@@ -485,7 +485,7 @@ and add_implementation_binding bv l =
 
 and add_top_phrase bv = function
   | Ptop_def str -> add_structure bv str
-  | Ptop_dir (_, _) -> bv
+  | Ptop_dir _ -> bv
 
 and add_class_expr bv ce =
   match ce.pcl_desc with

parsing/parser.mly

@@ -427,6 +427,18 @@ let package_type_of_module_type pmty =
       err pmty.pmty_loc
         "only module type identifier and 'with type' constraints are supported"
 
+let mk_directive_arg k =
+  { pdira_desc = k;
+    pdira_loc = symbol_rloc ()
+  }
+
+let mk_directive name arg =
+  Ptop_dir {
+      pdir_name = name;
+      pdir_arg = arg;
+      pdir_loc = symbol_rloc ()
+    }
+
 
 %}
 
@@ -2506,14 +2518,21 @@ class_longident:
 /* Toplevel directives */
 
 toplevel_directive:
-    HASH ident                 { Ptop_dir($2, Pdir_none) }
-  | HASH ident STRING          { Ptop_dir($2, Pdir_string (fst $3)) }
-  | HASH ident INT             { let (n, m) = $3 in
-                                  Ptop_dir($2, Pdir_int (n ,m)) }
-  | HASH ident val_longident   { Ptop_dir($2, Pdir_ident $3) }
-  | HASH ident mod_longident   { Ptop_dir($2, Pdir_ident $3) }
-  | HASH ident FALSE           { Ptop_dir($2, Pdir_bool false) }
-  | HASH ident TRUE            { Ptop_dir($2, Pdir_bool true) }
+    HASH ident
+    { mk_directive (mkrhs $2 2) None }
+  | HASH ident toplevel_directive_argument
+    { mk_directive (mkrhs $2 2) (Some $3) }
+;
+
+toplevel_directive_argument:
+  | STRING        { let (s, _) = $1 in
+                    mk_directive_arg (Pdir_string s) }
+  | INT           { let (n, m) = $1 in
+                    mk_directive_arg (Pdir_int (n ,m)) }
+  | val_longident { mk_directive_arg (Pdir_ident $1) }
+  | mod_longident { mk_directive_arg (Pdir_ident $1) }
+  | FALSE         { mk_directive_arg (Pdir_bool false) }
+  | TRUE          { mk_directive_arg (Pdir_bool true) }
 ;
 
 /* Miscellaneous */

parsing/parsetree.mli

@@ -870,11 +870,23 @@ and module_binding =
 
 type toplevel_phrase =
   | Ptop_def of structure
-  | Ptop_dir of string * directive_argument
+  | Ptop_dir of toplevel_directive
      (* #use, #load ... *)
 
+and toplevel_directive =
+  {
+    pdir_name : string loc;
+    pdir_arg : directive_argument option;
+    pdir_loc : Location.t;
+  }
+
 and directive_argument =
-  | Pdir_none
+  {
+    pdira_desc : directive_argument_desc;
+    pdira_loc : Location.t;
+  }
+
+and directive_argument_desc =
   | Pdir_string of string
   | Pdir_int of string * char option
   | Pdir_ident of Longident.t

parsing/pprintast.ml

@@ -1503,8 +1503,7 @@ and label_x_expression_param ctxt f (l,e) =
         pp f "~%s:%a" lbl (simple_expr ctxt) e
 
 and directive_argument f x =
-  match x with
-  | Pdir_none -> ()
+  match x.pdira_desc with
   | Pdir_string (s) -> pp f "@ %S" s
   | Pdir_int (n, None) -> pp f "@ %s" n
   | Pdir_int (n, Some m) -> pp f "@ %s%c" n m
@@ -1517,9 +1516,10 @@ let toplevel_phrase f x =
    (* pp_open_hvbox f 0; *)
    (* pp_print_list structure_item f s ; *)
    (* pp_close_box f (); *)
-  | Ptop_dir (s, da) ->
-   pp f "@[<hov2>#%s@ %a@]" s directive_argument da
-   (* pp f "@[<hov2>#%s@ %a@]" s directive_argument da *)
+  | Ptop_dir {pdir_name; pdir_arg = None; _} ->
+   pp f "@[<hov2>#%s@]" pdir_name.txt
+  | Ptop_dir {pdir_name; pdir_arg = Some pdir_arg; _} ->
+   pp f "@[<hov2>#%s@ %a@]" pdir_name.txt directive_argument pdir_arg
 
 let expression f x =
   pp f "@[%a@]" (expression reset_ctxt) x

parsing/printast.ml

@@ -910,13 +910,14 @@ let rec toplevel_phrase i ppf x =
   | Ptop_def (s) ->
       line i ppf "Ptop_def\n";
       structure (i+1) ppf s;
-  | Ptop_dir (s, da) ->
-      line i ppf "Ptop_dir \"%s\"\n" s;
-      directive_argument i ppf da;
+  | Ptop_dir {pdir_name; pdir_arg; _} ->
+      line i ppf "Ptop_dir \"%s\"\n" pdir_name.txt;
+      match pdir_arg with
+      | None -> ()
+      | Some da -> directive_argument i ppf da;
 
 and directive_argument i ppf x =
-  match x with
-  | Pdir_none -> line i ppf "Pdir_none\n"
+  match x.pdira_desc with
   | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s;
   | Pdir_int (n, None) -> line i ppf "Pdir_int %s\n" n;
   | Pdir_int (n, Some m) -> line i ppf "Pdir_int %s%c\n" n m;

tools/caml_tex.ml

@@ -538,7 +538,7 @@ module Ellipsis = struct
 
   let find = function
     | Parsetree.Ptop_def ast -> extract (fun it -> it.structure it) ast
-    | Ptop_dir (_,_) -> []
+    | Ptop_dir _ -> []
 
 end
 

tools/eqparsetree.ml

@@ -766,19 +766,27 @@ and eq_expression : (expression * expression) -> 'result =
      { pexp_desc = b0; pexp_loc = b1 })
     -> (eq_expression_desc (a0, b0)) && (Location.eq_t (a1, b1))
 
-let rec eq_directive_argument :
-  (directive_argument * directive_argument) -> 'result =
+let rec eq_directive_argument_desc :
+  (directive_argument_desc * directive_argument_desc) -> 'result =
   function
   | (Pdir_none, Pdir_none) -> true
   | (Pdir_string a0, Pdir_string b0) -> eq_string (a0, b0)
   | (Pdir_int a0, Pdir_int b0) -> eq_int (a0, b0)
   | (Pdir_ident a0, Pdir_ident b0) -> Longident.eq_t (a0, b0)
   | (Pdir_bool a0, Pdir_bool b0) -> eq_bool (a0, b0)
   | (_, _) -> false
+and eq_directive_argument :
+  (directive_argument * directive_argument) -> 'result =
+  fun
+    ({pdira_desc = a0; pdira_loc = a1},
+     {pdira_desc = b0; pdira_loc = b1})
+    -> (eq_directive_argument_desc (a0, b0)) && (Location.eq_t (a1, b1))
+
 and eq_toplevel_phrase :
   (toplevel_phrase * toplevel_phrase) -> 'result =
   function
   | (Ptop_def a0, Ptop_def b0) -> eq_structure (a0, b0)
-  | (Ptop_dir (a0, a1), Ptop_dir (b0, b1)) ->
-      (eq_string (a0, b0)) && (eq_directive_argument (a1, b1))
+  | (Ptop_dir a0, Ptop_dir a1) ->
+    Asttypes.eq_loc eq_string (a0.pdir_name, b0.pdir_name) &&
+    (eq_directive_argument (a1, b1))
   | (_, _) -> false

toplevel/opttoploop.ml

@@ -362,7 +362,7 @@ let execute_phrase print_outcome ppf phr =
       with x ->
         toplevel_env := oldenv; raise x
       end
-  | Ptop_dir(dir_name, dir_arg) ->
+  | Ptop_dir {pdir_name = {Location.txt = dir_name}; pdir_arg } ->
       let d =
         try Some (Hashtbl.find directive_table dir_name)
         with Not_found -> None
@@ -372,10 +372,10 @@ let execute_phrase print_outcome ppf phr =
           fprintf ppf "Unknown directive `%s'.@." dir_name;
           false
       | Some d ->
-          match d, dir_arg with
-          | Directive_none f, Pdir_none -> f (); true
-          | Directive_string f, Pdir_string s -> f s; true
-          | Directive_int f, Pdir_int (n,None) ->
+          match d, pdir_arg with
+          | Directive_none f, None -> f (); true
+          | Directive_string f, Some {pdira_desc = Pdir_string s} -> f s; true
+          | Directive_int f, Some {pdira_desc = Pdir_int (n,None)} ->
              begin match Int_literal_converter.int n with
              | n -> f n; true
              | exception _ ->
@@ -384,12 +384,12 @@ let execute_phrase print_outcome ppf phr =
                        dir_name;
                false
              end
-          | Directive_int _, Pdir_int (_, Some _) ->
+          | Directive_int _, Some {pdira_desc = Pdir_int (_, Some _)} ->
               fprintf ppf "Wrong integer literal for directive `%s'.@."
                 dir_name;
               false
-          | Directive_ident f, Pdir_ident lid -> f lid; true
-          | Directive_bool f, Pdir_bool b -> f b; true
+          | Directive_ident f, Some {pdira_desc = Pdir_ident lid} -> f lid; true
+          | Directive_bool f, Some {pdira_desc = Pdir_bool b} -> f b; true
           | _ ->
               fprintf ppf "Wrong type of argument for directive `%s'.@."
                 dir_name;

toplevel/toploop.ml

@@ -300,7 +300,7 @@ let execute_phrase print_outcome ppf phr =
       with x ->
         toplevel_env := oldenv; raise x
       end
-  | Ptop_dir(dir_name, dir_arg) ->
+  | Ptop_dir {pdir_name = {Location.txt = dir_name}; pdir_arg } ->
       let d =
         try Some (Hashtbl.find directive_table dir_name)
         with Not_found -> None
@@ -315,10 +315,10 @@ let execute_phrase print_outcome ppf phr =
           fprintf ppf "@.";
           false
       | Some d ->
-          match d, dir_arg with
-          | Directive_none f, Pdir_none -> f (); true
-          | Directive_string f, Pdir_string s -> f s; true
-          | Directive_int f, Pdir_int (n,None) ->
+          match d, pdir_arg with
+          | Directive_none f, None -> f (); true
+          | Directive_string f, Some {pdira_desc = Pdir_string s} -> f s; true
+          | Directive_int f, Some {pdira_desc = Pdir_int (n,None) } ->
              begin match Int_literal_converter.int n with
              | n -> f n; true
              | exception _ ->
@@ -327,12 +327,12 @@ let execute_phrase print_outcome ppf phr =
                        dir_name;
                false
              end
-          | Directive_int _, Pdir_int (_, Some _) ->
+          | Directive_int _, Some {pdira_desc = Pdir_int (_, Some _)} ->
               fprintf ppf "Wrong integer literal for directive `%s'.@."
                 dir_name;
               false
-          | Directive_ident f, Pdir_ident lid -> f lid; true
-          | Directive_bool f, Pdir_bool b -> f b; true
+          | Directive_ident f, Some {pdira_desc = Pdir_ident lid} -> f lid; true
+          | Directive_bool f, Some {pdira_desc = Pdir_bool b} -> f b; true
           | _ ->
               fprintf ppf "Wrong type of argument for directive `%s'.@."
                 dir_name;