From ab05f2d000f18055c16f63fc14c6f21a55861bbc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Wed, 10 Jun 2026 11:30:59 +0200 Subject: [PATCH 1/2] remove current dir prefix when printing positions --- src/cli/config.ml | 2 +- src/common/pos.ml | 15 ++++++++------- src/lplib/string.ml | 11 +++++++++++ 3 files changed, 20 insertions(+), 8 deletions(-) diff --git a/src/cli/config.ml b/src/cli/config.ml index 96797290c..2d30d446e 100644 --- a/src/cli/config.ml +++ b/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 diff --git a/src/common/pos.ml b/src/common/pos.ml index 7996894fe..7b90ac1ee 100644 --- a/src/common/pos.ml +++ b/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 @@ -159,15 +163,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. "
\n"). [delimiters] is a pair of delimiters used to wrap the diff --git a/src/lplib/string.ml b/src/lplib/string.ml index e7097423a..4e40d23b6 100644 --- a/src/lplib/string.ml +++ b/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 From 5fc5166bc530ebe832bbbcd40a00e467cf5c1100 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Blanqui?= Date: Wed, 10 Jun 2026 12:16:36 +0200 Subject: [PATCH 2/2] wip --- src/common/pos.ml | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/common/pos.ml b/src/common/pos.ml index 7b90ac1ee..1db0bfa30 100644 --- a/src/common/pos.ml +++ b/src/common/pos.ml @@ -119,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 =