remove current dir prefix when printing positions

src/cli/config.ml

@@ -61,7 +61,7 @@ let init : config -> unit = fun cfg ->
   (* Log some configuration data. *)
   if Logger.log_enabled () then
     begin
-      Library.log "running directory: %s" (Filename.current_dir ());
+      Library.log "running directory: %s" Pos.cur_dir;
       Library.log "library root path: %s"
         (match !lib_root with None -> assert false | Some(p) -> p);
       let f = Library.log "mapping: %a → %s" Path.pp in

src/common/pos.ml

@@ -2,6 +2,8 @@
 
 open Lplib open Base
 
+let cur_dir = Filename.current_dir()
+
 (** Type of a position, corresponding to a continuous range of characters in a
     (utf8-encoded) source. *)
 type pos =
@@ -64,7 +66,11 @@ let to_string : ?print_dirname:bool -> ?print_fname:bool -> pos -> string =
     if print_fname then
       match fname with
       | None -> ""
-      | Some n -> (if print_dirname then n else Filename.basename n) ^ ":"
+      | Some n ->
+          (if print_dirname
+           then String.remove_prefix (cur_dir^Filename.dir_sep) n
+           else Filename.basename n)
+          ^ ":"
     else ""
   in
   if start_line <> end_line then
@@ -74,8 +80,6 @@ let to_string : ?print_dirname:bool -> ?print_fname:bool -> pos -> string =
   else
     Printf.sprintf "%s%d:%d-%d" fname start_line start_col end_col
 
-
-
 (** Type of optional positions. *)
 type popt = pos option
 
@@ -115,8 +119,6 @@ let lexing_opt (p:popt): Lexing.position =
   | None -> {pos_fname=""; pos_lnum=1; pos_bol=0; pos_cnum=0}
   | Some p -> lexing p
 
-
-
 (** Type constructor extending a type (e.g. a piece of abstract syntax) with a
     an optional source code position. *)
 type 'a loc =
@@ -159,15 +161,12 @@ let pp : popt pp = fun ppf p ->
 
 (** [short ppf pos] prints the optional position [pos] on [ppf]. *)
 let short : popt pp = fun ppf p ->
-  let print_fname=false in
-  string ppf (popt_to_string ~print_fname p)
+  string ppf (popt_to_string ~print_fname:false p)
 
 (** [pp_lexing ppf lps] prints the Lexing.position pair [lps] on [ppf]. *)
 let pp_lexing : (Lexing.position * Lexing.position) pp =
   fun ppf lps -> short ppf (Some (locate lps))
 
-
-
 (** [print_file_contents escape sep delimiters pos] prints the contents of the
     file at position [pos]. [sep] is the separator replacing each newline
     (e.g. "<br>\n"). [delimiters] is a pair of delimiters used to wrap the

src/lplib/string.ml

@@ -30,6 +30,17 @@ let is_prefix : string -> string -> bool =
   let len_s = S.length s in
   len_p <= len_s && S.sub s 0 len_p = p
 
+let remove_prefix (prefix:string) (s:string): string =
+  if is_prefix prefix s then
+    let len_p = S.length prefix in
+    S.sub s len_p (S.length s - len_p)
+  else s
+
+let _ =
+  assert (remove_prefix "" "a" = "a");
+  assert (remove_prefix "a" "ba" = "ba");
+  assert (remove_prefix "a" "ab" = "b")
+
 let for_all : (char -> bool) -> string -> bool =
  fun p s ->
   let len_s = S.length s in