Capture locations of string-with-vars generated inside jbuilder

src/jbuild.ml

@@ -730,79 +730,83 @@ module Rule = struct
         sexp
 
   let ocamllex_v1 names =
-    let str s = String_with_vars.of_string s ~loc:Loc.none in
+    let module S = String_with_vars in
     List.map names ~f:(fun name ->
       let src = name ^ ".mll" in
       let dst = name ^ ".ml"  in
       { targets = Static [dst]
-      ; deps    = [File (str src)]
+      ; deps    = [File (S.virt_text __POS__ src)]
       ; action  =
           Chdir
-            (str "${ROOT}",
+            (S.virt_var __POS__ "ROOT",
-             Run (str "${bin:ocamllex}",
+             Run (S.virt_text __POS__ "ocamllex",
-                  [str "-q"; str "-o"; str "${@}"; str "${<}"]))
+                  [ S.virt_text __POS__ "-q"
+                  ; S.virt_text __POS__ "-o"
+                  ; S.virt_var __POS__ "@"
+                  ; S.virt_var __POS__"<"
+                  ]))
       })
 
   let ocamlyacc_v1 names =
-    let str s = String_with_vars.of_string s ~loc:Loc.none in
+    let module S = String_with_vars in
     List.map names ~f:(fun name ->
       let src = name ^ ".mly" in
       { targets = Static [name ^ ".ml"; name ^ ".mli"]
-      ; deps    = [File (str src)]
+      ; deps    = [File (S.virt_text __POS__ src)]
       ; action  =
           Chdir
-            (str "${ROOT}",
+            (S.virt_var __POS__ "ROOT",
-             Run (str "${bin:ocamlyacc}",
+             Run (S.virt_text __POS__ "ocamlyacc",
-                  [str "${<}"]))
+                  [S.virt_var __POS__ "<"]))
       })
 end
 
 module Menhir = struct
   type t =
-    { base : string option
+    { merge_into : string option
-    ; flags : String_with_vars.t list
+    ; flags      : String_with_vars.t list
-    ; modules: string list
+    ; modules    : string list
     }
 
   let v1 =
     record
-      (field_o "merge_into" string >>= fun base ->
+      (field_o "merge_into" string >>= fun merge_into ->
        field "flags" (list String_with_vars.t) ~default:[] >>= fun flags ->
        field "modules" (list string) >>= fun modules ->
        return
-         { base
+         { merge_into
          ; flags
          ; modules
          }
       )
 
   let v1_to_rule t =
-    let str s = String_with_vars.of_string s ~loc:Loc.none in
+    let module S = String_with_vars in
     let targets n = [n ^ ".ml"; n ^ ".mli"] in
-    match t.base with
+    match t.merge_into with
     | None ->
       List.map t.modules ~f:(fun name ->
         let src = name ^ ".mly" in
         { Rule.
           targets = Static (targets name)
-        ; deps    = [Dep_conf.File (str src)]
+        ; deps    = [Dep_conf.File (S.virt_text __POS__ src)]
         ; action  =
             Chdir
-              (str "${ROOT}",
+              (S.virt_var __POS__ "ROOT",
-               Run (str "${bin:menhir}",
+               Run (S.virt_text __POS__ "menhir",
-                    t.flags @ [str "${<}"]))
+                    t.flags @ [S.virt_var __POS__ "<"]))
         })
-    | Some base ->
+    | Some merge_into ->
-      let mly m = str (m ^ ".mly") in
+      let mly m = S.virt_text __POS__ (m ^ ".mly") in
       [{ Rule.
-         targets = Static (targets base)
+         targets = Static (targets merge_into)
        ; deps    = List.map ~f:(fun m -> Dep_conf.File (mly m)) t.modules
        ; action  =
            Chdir
-             (str "${ROOT}",
+             (S.virt_var __POS__ "ROOT",
-              Run (str "${bin:menhir}",
+              Run (S.virt_text __POS__ "menhir",
-                   [ str "--base"
+                   [ S.virt_text __POS__ "--base"
-                   ; str base
+                   ; S.virt_text __POS__ merge_into
                    ]
                    @ t.flags
                    @ (List.map ~f:mly t.modules))

src/loc.ml

@@ -37,6 +37,18 @@ let in_file fn =
   ; stop = pos
   }
 
+let of_pos (fname, lnum, cnum, enum) =
+  let pos : Lexing.position =
+    { pos_fname = fname
+    ; pos_lnum  = lnum
+    ; pos_cnum  = cnum
+    ; pos_bol   = 0
+    }
+  in
+  { start = pos
+  ; stop  = { pos with pos_cnum = enum }
+  }
+
 let none = in_file "<none>"
 
 let print ppf { start; stop } =

src/loc.mli

@@ -12,6 +12,9 @@ val fail_lex : Lexing.lexbuf -> ('a, Format.formatter, unit, 'b) format4 -> 'a
 
 val in_file : string -> t
 
+(** To be used with [__POS__] *)
+val of_pos : (string * int * int * int) -> t
+
 val none : t
 
 (** Prints "File ..., line ..., characters ...:\n" *)

src/string_with_vars.ml

@@ -65,7 +65,9 @@ let t sexp = of_string ~loc:(Sexp.Ast.loc sexp) (Sexp.Of_sexp.string sexp)
 
 let loc t = t.loc
 
-let raw ~loc s = { loc; items = [Text s]}
+let virt pos s = of_string ~loc:(Loc.of_pos pos) s
+let virt_var  pos s = { loc = Loc.of_pos pos; items = [Var (Braces, s)] }
+let virt_text pos s = { loc = Loc.of_pos pos; items = [Text s] }
 
 let just_a_var t =
   match t.items with

src/string_with_vars.mli

@@ -11,9 +11,13 @@ val sexp_of_t : t -> Sexp.t
 
 val loc : t -> Loc.t
 
-val of_string : loc:Loc.t -> string -> t
 val to_string : t -> string
-val raw : loc:Loc.t -> string -> t
+
+(** [t] generated by the OCaml code. The first argument should be [__POS__]. The second is
+    either a string to parse, a variable name or plain text. *)
+val virt      : (string * int * int * int) -> string -> t
+val virt_var  : (string * int * int * int) -> string -> t
+val virt_text : (string * int * int * int) -> string -> t
 
 val just_a_var : t -> string option
 

src/super_context.ml

@@ -818,8 +818,8 @@ module PP = struct
       Hashtbl.add sctx.ppx_drivers ~key ~data:exe;
       exe
 
-  let target_var = String_with_vars.of_string "${@}" ~loc:Loc.none
+  let target_var = String_with_vars.virt_var __POS__ "@"
-  let root_var   = String_with_vars.of_string "${ROOT}" ~loc:Loc.none
+  let root_var   = String_with_vars.virt_var __POS__ "ROOT"
 
   let cookie_library_name lib_name =
     match lib_name with