Commits

camlspotter  committed 62f167f

Filepath is reimplemented using Filename of OCaml stdlib

  • Participants
  • Parent commits 748fe13
  • Branches 4.01.0.2.2.0+win

Comments (0)

Files changed (9)

 command.cmx : command.cmi
 compdir.cmo : utils.cmi filepath.cmi dotfile.cmi compdir.cmi
 compdir.cmx : utils.cmx filepath.cmx dotfile.cmx compdir.cmi
+copiedfilename.cmo :
+copiedfilename.cmx :
 dotfile.cmo : utils.cmi dotfile.cmi
 dotfile.cmx : utils.cmx dotfile.cmi
 ext.cmo : xprinttyp.cmi xpath.cmi xlongident.cmi xident.cmi
 ext.cmx : xprinttyp.cmx xpath.cmx xlongident.cmx xident.cmx
 fileident.cmo : utils.cmi fileident.cmi
 fileident.cmx : utils.cmx fileident.cmi
-filepath.cmo : utils.cmi filepath.cmi
-filepath.cmx : utils.cmx filepath.cmi
+filepath.cmo : utils.cmi copiedfilename.cmo filepath.cmi
+filepath.cmx : utils.cmx copiedfilename.cmx filepath.cmi
 locident.cmo : locident.cmi
 locident.cmx : locident.cmi
 name.cmo : name.cmi
     cmt.cmx
 pathreparse.cmo : utils.cmi spot.cmi locident.cmi ext.cmo pathreparse.cmi
 pathreparse.cmx : utils.cmx spot.cmx locident.cmx ext.cmx pathreparse.cmi
-record.cmo :
-record.cmx :
 spot.cmo : utils.cmi treeset.cmi ext.cmo cmt.cmi checksum.cmo spot.cmi
 spot.cmx : utils.cmx treeset.cmx ext.cmx cmt.cmx checksum.cmx spot.cmi
 spotconfig.cmo : utils.cmi spot.cmi ext.cmo spotconfig.cmi
 # Requires unix!
 COMPFLAGS= -g $(INCLUDES_DEP) -I +unix
 
-MODULES= utils checksum fileident filepath dotfile compdir xset treeset command typeexpand \
+MODULES= utils checksum fileident copiedfilename filepath dotfile compdir xset treeset command typeexpand \
 	xlongident name xident xpath locident typeFix xprinttyp ext cmt spot spoteval spotconfig_intf spotconfig spotfile ocamlspot # pathreparse 
 
 OBJS=		$(addsuffix .cmo, $(MODULES))
   let module FP = Filepath in
   (* CR jfuruse: we should create a function for this *)
   let path = if Filename.is_relative path then Unix.getcwd () ^/ path else path in
-  let fp = FP.of_string path in
+  let fp = FP.of_string FP.os path in
   match FP.dirbase fp with
   | _, None -> failwithf "Error: %s is not a normal file path" path
   | dir, Some base ->
             else find fps
       in
       find (match Filename.split_extension base with
-      | body, (".cmi" | ".cmti" | ".spit") -> [ FP.(^/) dir (FP.of_string (body ^ ".cmti")) ]
-      | body, (".cmo" | ".cmx" | ".cmt" | ".spot") -> [ FP.(^/) dir (FP.of_string (body ^ ".cmt")) ]
+      | body, (".cmi" | ".cmti" | ".spit") -> [ FP.(^/) dir (body ^ ".cmti") ]
+      | body, (".cmo" | ".cmx" | ".cmt" | ".spot") -> [ FP.(^/) dir (body ^ ".cmt") ]
       | body, ".mli" -> 
-          [ FP.(^/) (Compdir.comp_dir dir ) (FP.of_string (body ^ ".cmti"));
-            FP.(^/) dir (FP.of_string (body ^ ".cmti")); ]
+          [ FP.(^/) (Compdir.comp_dir dir ) (body ^ ".cmti");
+            FP.(^/) dir (body ^ ".cmti"); ]
       | body, _ (* .ml, mll, mly, or eliom *) -> 
-          [ FP.(^/) (Compdir.comp_dir dir ) (FP.of_string (body ^ ".cmt"));
-            FP.(^/) dir (FP.of_string (body ^ ".cmt")) ])
+          [ FP.(^/) (Compdir.comp_dir dir ) (body ^ ".cmt");
+            FP.(^/) dir (body ^ ".cmt") ])
 
 (* CR jfuruse: this is a dirty workaround. It should be nice if we could know cmt is created by opt or byte *)          
 let is_opt cmt = 
 let rec find_dot_ocamlspot fp = 
   let open FP in
   match
-    if Unix.is_dir (FP.to_string (fp ^/ FP.of_string "_build")) then Some (fp, "_build")
+    if Unix.is_dir FP.(to_string (fp ^/ "_build")) then Some (fp, "_build")
     else
-      let dot_ocamlspot = fp ^/ FP.of_string ".ocamlspot" in
+      let dot_ocamlspot = fp ^/ ".ocamlspot" in
       if Sys.file_exists (FP.to_string dot_ocamlspot) then
         match (Dotfile.load (FP.to_string dot_ocamlspot)).Dotfile.build_dir with
         | Some dir -> Some (fp, dir)
         match FP.is_prefix dir fp0 with
         | None -> fp0
         | Some postfixes ->
-            match FP.is_prefix (FP.(^/) dir (FP.of_string mv)) fp0 with
+            match FP.(is_prefix (dir ^/ mv) fp0) with
             | Some _ -> fp0 (* already in the comp dir *)
-            | None -> 
-                (* CR jfuruse: inefficient *)
-                FP.of_string (Filename.concats (FP.to_string dir :: mv :: FP.to_list postfixes))
+            | None -> FP.concats dir (mv :: postfixes)
 
 let comp_dir x =
   let y = comp_dir x in
     match find_dot_ocamlspot fp0 with
     | None -> fp0
     | Some (dir, mv) ->
-        match FP.is_prefix (FP.(^/) dir (FP.of_string mv)) fp0 with
+        match FP.(is_prefix (dir ^/ mv) fp0) with
         | None -> fp0
-        | Some postfixes -> FP.(^/) dir postfixes
+        | Some postfixes -> FP.concats dir postfixes
 
 let src_file x =
   let y = src_file x in
 
 open Utils
 
-open Filename
+module Filename = Copiedfilename
 
+module type Filename = sig
+  val current_dir_name : string
+  val parent_dir_name : string
+  val dir_sep : string
+  val is_dir_sep : string -> int -> bool
+  val is_relative : string -> bool
+  val is_implicit : string -> bool
+  val check_suffix : string -> string -> bool
+  val temp_dir_name : string
+  val quote : string -> string
+  val basename : string -> string
+  val dirname : string -> string
+
+  val has_drive : string -> bool
+  val drive_and_path : string -> string * string
+
+  val normalize_drive : string -> string
+  val is_network_drive : string -> bool
+end
+
+module Unix : Filename = struct
+  include Filename.Unix
+  let has_drive _ = false
+  let drive_and_path s = "", s
+  let normalize_drive s = s
+  let is_network_drive _ = false
+end
+
+let () =
+  assert (String.sub' "hello" 0 4 = "hell");
+  assert (String.sub' "hello" 0 5 = "hello");
+  assert (String.sub' "hello" 0 6 = "hello");
+  assert (String.sub' "hello" 0 7 = "hello");
+  assert (String.sub' "hello" 3 2 = "lo");
+  assert (String.sub' "hello" 3 3 = "lo");
+  assert (String.sub' "hello" 3 4 = "lo");
+  assert (String.sub' "hello" 5 5 = "")
+
+module Win32 : Filename = struct
+  include Filename.Win32
+    
+  (* We think network drives too *)
+  (* CR jfuruse: it returns true even for "///" *)
+  let has_drive s =
+    has_drive s 
+    || match String.sub' s 0 2 with
+      | "//" | "\\\\" -> true
+      | _ -> false
+
+  let drive_and_path s = 
+    match drive_and_path s with
+    | "", s ->
+        begin match String.sub' s 0 2 with
+        | ("//" | "\\\\" as s) -> s, String.sub s 2 (String.length s - 2)
+        | _ -> "", s
+        end
+    | res -> res
+
+  let normalize_drive s = String.replace_chars '/' '\\' (String.uppercase s)
+
+  let is_network_drive = function
+    | "//" | "\\\\" -> true
+    | _ -> false
+end
+
+module Cygwin : Filename = struct
+  include Filename.Cygwin
+  let has_drive = Win32.has_drive
+  let drive_and_path = Win32.drive_and_path
+  let normalize_drive s = String.replace_chars '\\' '/' (String.lowercase s)
+  let is_network_drive = Win32.is_network_drive
+end
+
+module Make(F : Filename) = struct
+  class c = object
+    method current = F.current_dir_name
+    method parent = F.parent_dir_name
+    method sep = F.dir_sep
+    method is_relative = F.is_relative
+    method is_absolute x = not (F.is_relative x)
+    method check_suffix = F.check_suffix
+    method dir_and_base s = F.dirname s, F.basename s
+    method temp_dir = F.temp_dir_name
+    method quote = F.quote
+    method drive_and_path = F.drive_and_path
+    method normalize_drive = F.normalize_drive
+    method is_network_drive = F.is_network_drive
+    method is_dir_sep = F.is_dir_sep
+  end
+end
+
+module MakeUnix = Make(Unix)
+
+type op = MakeUnix.c
+
+let unix   = let module M = Make(Unix)   in new M.c
+let win32  = let module M = Make(Win32)  in new M.c
+let cygwin = let module M = Make(Cygwin) in new M.c
+
+type os = 
+  | Unix (** We love *)
+  | Win32 (** We hate *)
+  | Cygwin (** a failed effort of reconcillation *)
+
+let of_os = function
+  | Unix -> unix
+  | Win32 -> win32
+  | Cygwin -> cygwin
+
+let os = match Sys.os_type with
+  | "Unix" -> Unix
+  | "Win32" -> Win32
+  | "Cygwin" -> Cygwin
+  | _ -> assert false
+
+type t = { 
+  os : os;
+  op : op;
+  drive : string option; (** Some "C:",  Some "\\\\" or Some "//" *)
+  abs : bool;
+  revs : string list; (** reversed directory components: a/b/c => ["a"; "b"; "c"] *)
+  normalized : bool;
+}
+
+let of_string os s =
+  let f = of_os os in
+  let drive, p = f#drive_and_path s in
+  let drive = if drive = "" then None else Some drive in
+  let abs = drive <> None || f#is_absolute p in
+  let rec splits st s =
+    let d, b = f#dir_and_base s in
+    if f#is_dir_sep d 0 && f#is_dir_sep b 0 then
+      (* In Unix at least, it means [s] is ["/"] or ["////"]. *)
+      st
+    else
+      if s = d then s :: st
+      else splits (b::st) d
+  in
+  let revs = List.rev (splits [] s) in
+  { os; 
+    op = f;
+    drive;
+    abs;
+    revs;
+    normalized = false }
+  
+let normalize t =
+  if t.normalized then t
+  else
+    let f = t.op in
+    let drive = match t.drive with
+      | None -> None
+      | Some d -> Some (f#normalize_drive d)
+    in
+    (* xxx/./yyy => xxx/yyy
+       xxx/a/../yyy => xxx/yyy
+       /../../ => /../../
+    *)
+    let rec normalize_rev = function
+      | [] -> []
+      | x::xs when x = f#current -> normalize_rev xs
+      | x::xs when x = f#parent ->
+          let ys = normalize_rev xs in
+          begin match ys with
+          | [] when t.abs -> [] (* /.. => / *)
+          | [] -> [x] (* .. => .. *)
+          | z::_ when z = f#parent -> x::ys (* xxx/../.. => xxx/../.. *)
+          | _::zs -> zs (* xxx/z/.. => xxx *)
+          end
+      | x::xs -> x :: normalize_rev xs
+    in
+    let revs = normalize_rev t.revs in
+    { t with drive; revs; normalized = true }
+
+let to_string t =
+  let compos = List.rev t.revs in
+  let concats = String.concat t.op#sep in
+  match t.drive, t.abs with
+  | None, true -> concats ("" :: compos)
+  | None, false -> concats compos
+  | Some d, true when t.op#is_network_drive d -> d ^ concats compos
+  | Some d, false when t.op#is_network_drive d -> assert false
+  | Some d, true -> d ^ concats ("" :: compos)
+  | Some d, false -> d ^ concats compos
+      
+let is_absolute t = t.abs
+let is_relative t = not t.abs
+
+let is_root t = t.abs && let t = normalize t in t.revs = []
+
+let dirbase t = 
+  let t = normalize t in
+  match t.revs with
+  | [] -> t, None
+  | x::_ when x = t.op#parent -> invalid_arg "dirbase"
+  | x::xs -> { t with revs = xs }, Some x
+
+let (^/) x s = 
+  let y = of_string x.os s in
+  if is_absolute y then invalid_arg "(^/)"
+  else normalize { x with revs = y.revs @ x.revs; normalized = false }
+
+let concats x ss = List.fold_left (^/) x ss
+
+let parent t = 
+  let t = normalize t in
+  match t.revs with
+  | [] when t.abs -> t
+  | [] -> { t with revs = [ t.op#parent ] }
+  | x::_ when x = t.op#parent -> { t with revs = t.op#parent :: t.revs }
+  | _::xs -> { t with revs = xs }
+
+let wrap os f s = to_string (f (normalize (of_string os s)))
+
+let is_prefix x y =
+  if x.os = y.os && x.abs = y.abs then
+    let rec is_prefix xs ys = match xs, ys with
+      | [], ys -> Some ys
+      | x::xs, y::ys when x = y -> is_prefix xs ys
+      | _ -> None
+    in
+    is_prefix (List.rev x.revs) (List.rev y.revs)
+  else None
+
+(*
 let get_component : string -> string = Hashtbl.memoize (Hashtbl.create 1023) (fun x -> x)
 
 let dotdot = get_component (parent_dir_name)
 
-let root_normalize = 
-  match Sys.os_type with
-  | "Win32" ->
-      (* "c:/" => "C:\\" *)
-      (fun s -> 
-        let s = String.uppercase s in
-        String.iteri (fun p -> function
-          | '/' -> String.unsafe_set s p '\\'
-          | _ -> ()) s;
-        s)
-  | "Cygwin" ->
-      (* "C:\\" => "c:/" *)
-      (fun s ->
-        let s = String.lowercase s in
-        String.iteri (fun p -> function
-          | '\\' -> String.unsafe_set s p '/'
-          | _ -> ()) s;
-        s)
-  | _ -> (fun s -> s)
-
-let rec split st s =
-  let d = dirname s in
-  if d = s then get_component (root_normalize s) :: st
-  else 
-    let b = basename s in
-    split (get_component b :: st) d
-
-let split = split []
-
-let rec concats = function
-  | [] -> current_dir_name
-  | x::xs when not (is_relative x) -> x ^ concats xs
-  | xs -> String.concat dir_sep xs
-
 let test s = 
   let ss = split s in
   (* Format.eprintf "%s => %s@." s (concats ss); *)
 
 type t = string list
 
-let rec is_prefix xs ys =
-  match xs, ys with
-  | [], ys -> Some ys
-  | x::xs, y::ys when x = y -> is_prefix xs ys
-  | _ -> None
-
 let () = assert (is_prefix ["a"; "b"; "c"] ["a"; "b"; "c"; "d"; "e"] = Some ["d"; "e"])
 
 let of_string path = normalize (split path)
 
 let to_string = concats
 
-let is_absolute = function
-  | [] -> false
-  | x::_ -> not (is_relative x)
 
-let is_relative xs = not (is_absolute xs)
-
-let is_root = function
-  | ([_] as xs) -> is_absolute xs
-  | _ -> false
-
-let dirbase = function
-  | [] -> [], None
-  | xs ->
-      let rec dirbase rev = function
-        | [] -> assert false
-        | [x] -> List.rev rev, Some x
-        | x::xs -> dirbase (x::rev) xs
-      in
-      dirbase [] xs
-
-let (^/) xs ys = 
-  assert (is_relative ys);
-  normalize' (List.rev xs) ys
-
-let parent = function
-  | [] -> [parent_dir_name]
-  | [x] when is_absolute [x] -> [x]
-  | [x] when dirname x = x -> [x; dotdot]
-  | xs ->
-      let rec parent rev = function
-        | [] -> assert false
-        | [x] when x = parent_dir_name -> List.rev (parent_dir_name :: x :: rev)
-        | [_] -> List.rev rev
-        | x::xs -> parent (x::rev) xs
-      in
-      parent [] xs
-
-let wrap f s = to_string (f (of_string s))
-
-let to_list xs = xs
+*)

File filepath.mli

 
 (* File path normalization *)
 
+type os = 
+  | Unix (** We love *)
+  | Win32 (** We hate *)
+  | Cygwin (** a failed effort of reconcillation *)
+
+val os : os
+
 type t
 
-val is_prefix : t -> t -> t option
+val is_prefix : t -> t -> string list option
 (** contains_abs /a/b/c /a/b/c/d/e = Some ["d"; "e"] 
 *)
 
-val of_string : string -> t
+val of_string : os -> string -> t
 val to_string : t -> string
 
 val is_absolute : t -> bool
 (* val root : t *)
 val is_root : t -> bool
 val dirbase : t -> t * string option
-val (^/) : t -> t -> t
+val (^/) : t -> string -> t
+val concats : t -> string list -> t
 val parent : t -> t
-val wrap : (t -> t) -> string -> string
+val wrap : os -> (t -> t) -> string -> string
 
-val to_list : t -> string list

File ocamlspot.ml

     | None -> printf "Spot: no spot@."
     | Some (pident, res) -> 
         let src_file path =
-          let path' = FP.wrap Compdir.src_file path in
+          let path' = FP.wrap FP.os Compdir.src_file path in
           if path = path' then path 
           else
             if not (Sys.file_exists path') then begin
   	   else split beg (succ cur) in
       let wstart = skip_sep 0 in
       split wstart wstart
+
+
+  (** Same as [String.sub] but even if the string shorter for [len] 
+      the function succeeds and returns a shorter substring. 
+  *)
+  (* CR jfuruse: need tests *)
+  let sub' s pos len =
+    let orig_len = length s in
+    let len = max (min (pos + len) orig_len - pos) 0 in
+    sub s pos len
+
+  let find s pos f =
+    let len = length s in
+    let rec scan pos =
+      if pos >= len then None
+      else if f (unsafe_get s pos) then Some pos else scan (pos + 1)
+    in
+    scan pos
+
+  let replace_chars from to_ s =
+    let s' = copy s in
+    iteri (fun p -> function
+      | c when c = from -> unsafe_set s p to_
+      | _ -> ()) s';
+    s'
 end
 
 module Filename = struct
 module String : sig
   include module type of String
   val split : (char -> bool) -> string -> string list
+
+  val sub' : string -> int -> int -> string
+  (** Same as [String.sub] but even if the string shorter for [len] 
+      the function succeeds and returns a shorter substring. 
+  *)
+
+  val find : string -> int -> (char -> bool) -> int option
+
+  val replace_chars : char -> char -> string -> string
 end
 
 module Filename : sig