source.ml

(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
(*           OCaml port by John Malecki and Xavier Leroy                  *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(************************ Source management ****************************)

open Misc
open Primitives

let source_extensions = [".ml"]

(*** Conversion function. ***)

let source_of_module pos mdle =
  let pos_fname = pos.Lexing.pos_fname in
  if Sys.file_exists pos_fname then pos_fname else
  let is_submodule m m' =
    let len' = String.length m' in
    try
      (String.sub m 0 len') = m' && (String.get m len') = '.'
    with
        Invalid_argument _ -> false in
  let path =
    Hashtbl.fold
      (fun mdl dirs acc ->
        if is_submodule mdle mdl then
          dirs
        else
          acc)
      Debugger_config.load_path_for
      (Load_path.get_paths ()) in
  let fname = pos.Lexing.pos_fname in
  if fname = "" then
    let innermost_module =
      try
        let dot_index = String.rindex mdle '.' in
        String.sub mdle (succ dot_index) (pred (String.length mdle - dot_index))
      with Not_found -> mdle in
    let rec loop =
      function
        | [] -> raise Not_found
        | ext :: exts ->
          try find_in_path_uncap path (innermost_module ^ ext)
          with Not_found -> loop exts
    in loop source_extensions
  else if Filename.is_relative fname then
    find_in_path_rel path fname
  else if Sys.file_exists fname then fname
  else raise Not_found

(*** Buffer cache ***)

(* Buffer and cache (to associate lines and positions in the buffer). *)
type buffer = string * (int * int) list ref

let buffer_max_count = ref 10

let buffer_list =
  ref ([] : (string * buffer) list)

let flush_buffer_list () =
  buffer_list := []

let get_buffer pos mdle =
  try List.assoc mdle !buffer_list with
    Not_found ->
      let inchan = open_in_bin (source_of_module pos mdle) in
      let content = really_input_string inchan (in_channel_length inchan) in
      let buffer = (content, ref []) in
      buffer_list :=
        (list_truncate !buffer_max_count ((mdle, buffer)::!buffer_list));
      buffer

let buffer_content =
  (fst : buffer -> string)

let buffer_length x =
  String.length (buffer_content x)

(*** Position conversions. ***)

type position = int * int

(* Insert a new pair (position, line) in the cache of the given buffer. *)
let insert_pos buffer ((position, line) as pair) =
  let rec new_list =
    function
      [] ->
        [(position, line)]
    | ((_pos, lin) as a::l) as l' ->
        if lin < line then
          pair::l'
        else if lin = line then
          l'
        else
          a::(new_list l)
  in
    let buffer_cache = snd buffer in
      buffer_cache := new_list !buffer_cache

(* Position of the next linefeed after `pos'. *)
(* Position just after the buffer end if no linefeed found. *)
(* Raise `Out_of_range' if already there. *)
let next_linefeed (buffer, _) pos =
  let len = String.length buffer in
    if pos >= len then
      raise Out_of_range
    else
      let rec search p =
        if p = len || String.get buffer p = '\n' then
          p
        else
          search (succ p)
      in
        search pos

(* Go to next line. *)
let next_line buffer (pos, line) =
  (next_linefeed buffer pos + 1, line + 1)

(* Convert a position in the buffer to a line number. *)
let line_of_pos buffer position =
  let rec find =
    function
    | [] ->
        if position < 0 then
          raise Out_of_range
        else
          (0, 1)
    | ((pos, _line) as pair)::l ->
        if pos > position then
          find l
        else
          pair
  and find_line previous =
    let (pos, _line) as next = next_line buffer previous in
      if pos <= position then
        find_line next
      else
        previous
  in
    let result = find_line (find !(snd buffer)) in
      insert_pos buffer result;
      result

(* Convert a line number to a position. *)
let pos_of_line buffer line =
  let rec find =
    function
      [] ->
        if line <= 0 then
          raise Out_of_range
        else
          (0, 1)
    | ((_pos, lin) as pair)::l ->
        if lin > line then
          find l
        else
          pair
  and find_pos previous =
    let (_, lin) as next = next_line buffer previous in
      if lin <= line then
        find_pos next
      else
        previous
  in
    let result = find_pos (find !(snd buffer)) in
      insert_pos buffer result;
      result

(* Convert a coordinate (line / column) into a position. *)
(* --- The first line and column are line 1 and column 1. *)
let point_of_coord buffer line column =
  fst (pos_of_line buffer line) + (pred column)

let start_and_cnum buffer pos =
  let line_number = pos.Lexing.pos_lnum in
  let start = point_of_coord buffer line_number 1 in
  start, start + (pos.Lexing.pos_cnum - pos.Lexing.pos_bol)