(****************************************************************************)

(*                                                                          *)

(*                                   OCaml                                  *)

(*                                                                          *)

(*                            INRIA Rocquencourt                            *)

(*                                                                          *)

(*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)

(*  en Automatique.  All rights reserved.  This file is distributed under   *)

(*  the terms of the GNU Library General Public License, with the special   *)

(*  exception on linking described in LICENSE at the top of the Camlp4      *)

(*  source tree.                                                            *)

(*                                                                          *)

(****************************************************************************)

(* Authors:

 * - Daniel de Rauglaudre: initial version

 * - Nicolas Pouillard: refactoring

 *)

(* camlp4r *)

open Format;

(* FIXME

   Study these 2 others implementations which change the ghost

   handling:

   type pos = ... the same ...

   1/

   type loc = {

     file_name : string;

     start     : pos;

     stop      : pos

   };

   type t =

     [ Nowhere

     | Ghost of loc (* the closest non ghost loc *)

     | Concrete of loc ];

   2/

   type loc = {

     file_name : string;

     start     : pos;

     stop      : pos

   };

   type t = option loc;

   3/

   type t = {

     file_name : option string;

     start     : pos;

     stop      : pos

   };

*)

type pos = {

  line : int;

  bol  : int;

  off  : int

};

type t = {

  file_name : string;

  start     : pos;

  stop      : pos;

  ghost     : bool

};

(* Debug section *)

value dump_sel f x =

  let s =

    match x with

    [ `start -> "`start"

    | `stop  -> "`stop"

    | `both  -> "`both"

    | _      -> "<not-printable>" ]

  in pp_print_string f s;

value dump_pos f x =

  fprintf f "@[<hov 2>{ line = %d ;@ bol = %d ;@ off = %d } : pos@]"

          x.line x.bol x.off;

value dump_long f x =

  fprintf f

    "@[<hov 2>{ file_name = %s ;@ start = %a (%d-%d);@ stop = %a (%d);@ ghost = %b@ } : Loc.t@]"

    x.file_name dump_pos x.start (x.start.off - x.start.bol)

    (x.stop.off - x.start.bol) dump_pos x.stop

    (x.stop.off - x.stop.bol) x.ghost;

value dump f x =

  fprintf f "[%S: %d:%d-%d %d:%d%t]"

    x.file_name x.start.line (x.start.off - x.start.bol)

    (x.stop.off - x.start.bol) x.stop.line (x.stop.off - x.stop.bol)

    (fun o -> if x.ghost then fprintf o " (ghost)" else ());

value start_pos = { line = 1 ; bol = 0 ; off = 0 };

value ghost =

  { file_name = "ghost-location";

    start     = start_pos;

    stop      = start_pos;

    ghost     = True     };

value mk file_name =

  debug loc "mk %s@\n" file_name in

  { file_name = file_name;

    start     = start_pos;

    stop      = start_pos;

    ghost     = False    };

value of_tuple (file_name, start_line, start_bol, start_off,

                          stop_line,  stop_bol,  stop_off, ghost) =

  { file_name = file_name;

    start     = { line = start_line ; bol = start_bol ; off = start_off };

    stop      = { line = stop_line  ; bol = stop_bol  ; off = stop_off  };

    ghost     = ghost };

value to_tuple

  { file_name = file_name;

    start     = { line = start_line ; bol = start_bol ; off = start_off };

    stop      = { line = stop_line  ; bol = stop_bol  ; off = stop_off  };

    ghost     = ghost } =

  (file_name, start_line, start_bol, start_off,

              stop_line,  stop_bol,  stop_off, ghost);

value pos_of_lexing_position p =

  let pos =

  { line = p.Lexing.pos_lnum ;

    bol  = p.Lexing.pos_bol  ;

    off  = p.Lexing.pos_cnum } in

  debug loc "pos_of_lexing_position: %a@\n" dump_pos pos in

  pos;

value pos_to_lexing_position p file_name =

  (* debug loc "pos_to_lexing_position: %a@\n" dump_pos p in *)

  { Lexing.

    pos_fname = file_name;

    pos_lnum  = p.line   ;

    pos_bol   = p.bol    ;

    pos_cnum  = p.off    };

value better_file_name a b =

  match (a, b) with

  [ ("", "") -> a

  | ("", x)  -> x

  | (x, "")  -> x

  | ("-", x) -> x

  | (x, "-") -> x

  | (x, _)   -> x ];

value of_lexbuf lb =

  let start = Lexing.lexeme_start_p lb

  and stop  = Lexing.lexeme_end_p lb in

  let loc =

  { file_name = better_file_name start.Lexing.pos_fname stop.Lexing.pos_fname;

    start     = pos_of_lexing_position start;

    stop      = pos_of_lexing_position stop;

    ghost     = False } in

  debug loc "of_lexbuf: %a@\n" dump loc in

  loc;

value of_lexing_position pos =

  let loc =

  { file_name = pos.Lexing.pos_fname;

    start     = pos_of_lexing_position pos;

    stop      = pos_of_lexing_position pos;

    ghost     = False } in

  debug loc "of_lexing_position: %a@\n" dump loc in

  loc;

value to_ocaml_location x =

  debug loc "to_ocaml_location: %a@\n" dump x in

  { Location.

    loc_start = pos_to_lexing_position x.start x.file_name;

    loc_end   = pos_to_lexing_position x.stop x.file_name;

    loc_ghost = x.ghost };

value of_ocaml_location { Location.loc_start = a; loc_end = b; loc_ghost = g } =

  let res =

    { file_name = better_file_name a.Lexing.pos_fname b.Lexing.pos_fname;

      start     = pos_of_lexing_position a;

      stop      = pos_of_lexing_position b;

      ghost     = g } in

  debug loc "of_ocaml_location: %a@\n" dump res in

  res;

value start_pos x = pos_to_lexing_position x.start x.file_name;

value stop_pos x = pos_to_lexing_position x.stop x.file_name;

value merge a b =

  if a == b then

    debug loc "trivial merge@\n" in

    a

  else

    let r =

      match (a.ghost, b.ghost) with

      [ (False, False) ->

        (* FIXME if a.file_name <> b.file_name then

          raise (Invalid_argument

            (sprintf "Loc.merge: Filenames must be equal: %s <> %s"

                    a.file_name b.file_name))                          *)

        (* else *)

          { (a) with stop = b.stop }

      | (True, True) -> { (a) with stop = b.stop }

      | (True, _) -> { (a) with stop = b.stop }

      | (_, True) -> { (b) with start = a.start } ]

    in debug loc "@[<hov 6>merge %a@ %a@ %a@]@\n" dump a dump b dump r in r;

value join x = { (x) with stop = x.start };

value map f start_stop_both x =

  match start_stop_both with

  [ `start -> { (x) with start = f x.start }

  | `stop  -> { (x) with stop  = f x.stop }

  | `both  -> { (x) with start = f x.start; stop  = f x.stop } ];

value move_pos chars x = { (x) with off = x.off + chars };

value move s chars x =

  debug loc "move %a %d %a@\n" dump_sel s chars dump x in

  map (move_pos chars) s x;

value move_line lines x =

  debug loc "move_line %d %a@\n" lines dump x in

  let move_line_pos x =

    { (x) with line = x.line + lines ; bol = x.off }

  in map move_line_pos `both x;

value shift width x =

  { (x) with start = x.stop ; stop = move_pos width x.stop };

value file_name  x = x.file_name;

value start_line x = x.start.line;

value stop_line  x = x.stop.line;

value start_bol  x = x.start.bol;

value stop_bol   x = x.stop.bol;

value start_off  x = x.start.off;

value stop_off   x = x.stop.off;

value is_ghost   x = x.ghost;

value set_file_name s x =

  debug loc "set_file_name: %a@\n" dump x in

  { (x) with file_name = s };

value ghostify x =

  debug loc "ghostify: %a@\n" dump x in

  { (x) with ghost = True };

value make_absolute x =

  debug loc "make_absolute: %a@\n" dump x in

  let pwd = Sys.getcwd () in

  if Filename.is_relative x.file_name then

    { (x) with file_name = Filename.concat pwd x.file_name }

  else x;

value strictly_before x y =

  let b = x.stop.off < y.start.off && x.file_name = y.file_name in

  debug loc "%a [strictly_before] %a => %b@\n" dump x dump y b in

  b;

value to_string x = do {

  let (a, b) = (x.start, x.stop) in

  let res = sprintf "File \"%s\", line %d, characters %d-%d"

                    x.file_name a.line (a.off - a.bol) (b.off - a.bol) in

  if x.start.line <> x.stop.line then

    sprintf "%s (end at line %d, character %d)"

            res x.stop.line (b.off - b.bol)

  else res

};

value print out x = pp_print_string out (to_string x);

value check x msg =

  if ((start_line x) > (stop_line x) ||

      (start_bol x) > (stop_bol x) ||

      (start_off x) > (stop_off x) ||

      (start_line x) < 0 || (stop_line x) < 0 ||

      (start_bol x) < 0 || (stop_bol x) < 0 ||

      (start_off x) < 0 ||  (stop_off x) < 0)

      (* Here, we don't check

        (start_off x) < (start_bol x) || (stop_off x) < (start_bol x)

        since the lexer is called on antiquotations, with off=0, but line and bolpos

        have "correct" values *)

  then do {

    eprintf "*** Warning: (%s) strange positions ***\n%a@\n" msg print x;

    False

  }

  else True;

exception Exc_located of t and exn;

ErrorHandler.register

  (fun ppf ->

    fun [ Exc_located loc exn ->

            fprintf ppf "%a:@\n%a" print loc ErrorHandler.print exn

        | exn -> raise exn ]);

value name = ref "_loc";

value raise loc exc =

  match exc with

  [ Exc_located _ _ -> raise exc

  | _ -> raise (Exc_located loc exc) ]

;