Source file FilePath.ml

(******************************************************************************)
(*  ocaml-fileutils: files and filenames common operations                    *)
(*                                                                            *)
(*  Copyright (C) 2003-2014, Sylvain Le Gall                                  *)
(*                                                                            *)
(*  This library is free software; you can redistribute it and/or modify it   *)
(*  under the terms of the GNU Lesser General Public License as published by  *)
(*  the Free Software Foundation; either version 2.1 of the License, or (at   *)
(*  your option) any later version, with the OCaml static compilation         *)
(*  exception.                                                                *)
(*                                                                            *)
(*  This library is distributed in the hope that it will be useful, but       *)
(*  WITHOUT ANY WARRANTY; without even the implied warranty of                *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file         *)
(*  COPYING for more details.                                                 *)
(*                                                                            *)
(*  You should have received a copy of the GNU Lesser General Public License  *)
(*  along with this library; if not, write to the Free Software Foundation,   *)
(*  Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA             *)
(******************************************************************************)

open FilePath_type

exception BaseFilenameRelative of filename
exception UnrecognizedOS of string
exception EmptyFilename
exception NoExtension of filename
exception InvalidFilename of filename

module type OS_SPECIFICATION =
sig
  val dir_writer: (filename_part list) -> filename
  val dir_reader: filename -> (filename_part list)
  val path_writer: (filename list) -> string
  val path_reader: string -> (filename list)
  val fast_concat: filename -> filename -> filename
  val fast_basename: filename -> filename
  val fast_dirname: filename -> filename
  val fast_is_relative: filename -> bool
  val fast_is_current: filename -> bool
  val fast_is_parent: filename -> bool
end


module type PATH_SPECIFICATION =
sig
  type filename
  type extension

  val string_of_filename: filename -> string
  val filename_of_string: string -> filename
  val extension_of_string: string -> extension
  val string_of_extension: extension -> string
  val make_filename: string list -> filename
  val is_subdir: filename -> filename -> bool
  val is_updir: filename -> filename -> bool
  val compare: filename -> filename -> int
  val basename: filename -> filename
  val dirname: filename -> filename
  val concat: filename -> filename -> filename
  val reduce: ?no_symlink:bool -> filename -> filename
  val make_absolute: filename -> filename -> filename
  val make_relative: filename -> filename -> filename
  val reparent: filename -> filename -> filename -> filename
  val identity: filename -> filename
  val is_valid: filename -> bool
  val is_relative: filename -> bool
  val is_current: filename -> bool
  val is_parent: filename -> bool
  val chop_extension: filename -> filename
  val get_extension: filename -> extension
  val check_extension: filename -> extension -> bool
  val add_extension: filename -> extension -> filename
  val replace_extension: filename -> extension -> filename
  val string_of_path: filename list -> string
  val path_of_string: string -> filename list
  val current_dir: filename
  val parent_dir: filename
end


module type PATH_STRING_SPECIFICATION =
sig
  module Abstract: PATH_SPECIFICATION

  include PATH_SPECIFICATION with
    type filename = string and
    type extension = string
end


(* Convert an OS_SPECIFICATION to PATH_SPECIFICATION *)
module GenericPath =
functor (OsOperation: OS_SPECIFICATION) ->
struct
  type filename = FilePath_type.filename_part list

  type extension = FilePath_type.extension

  (* Filename_from_string *)

  let filename_of_string str =
    try
      OsOperation.dir_reader str
    with Parsing.Parse_error ->
      raise (InvalidFilename str)

  (* String_from_filename *)

  let string_of_filename path =
    OsOperation.dir_writer path

  (* Reduce *)

  let reduce ?(no_symlink=false) path =
    (* TODO: not tail recursive ! *)
    let rec reduce_aux lst =
      match lst with
        | ParentDir :: tl when no_symlink ->
            begin
              match reduce_aux tl with
                | Root s :: tl ->
                    Root s :: tl
                | ParentDir :: tl ->
                    ParentDir :: ParentDir :: tl
                | [] ->
                    ParentDir :: tl
                | _ :: tl ->
                    tl
            end
        | ParentDir :: tl ->
            ParentDir :: (reduce_aux tl)
        | CurrentDir _ :: tl
        | Component "" :: tl ->
            (reduce_aux tl)
        | Component s :: tl ->
            Component s :: (reduce_aux tl)
        | Root s :: tl ->
            Root s :: (reduce_aux tl)
        | [] ->
            []
    in
    let rev_path = List.rev path in
    match reduce_aux rev_path with
      | [] when no_symlink = false->
	(* assert
  * ( List.for_all ( function | Component ""
  * | CurrentDir _ -> true | _ -> false ) rev_path ) *)
	(try
	   (* use last CurrentDir _ *)
	   [ List.find ( function | CurrentDir _ -> true | _ -> false ) rev_path ]
	 with
	   | Not_found -> [] ) (* Only Component "" *)
      |l -> List.rev l



  (* Compare, subdir, updir *)

  type filename_relation = SubDir | UpDir | Equal | NoRelation of int

  let relation_of_filename path1 path2 =
    let rec relation_of_filename_aux path1 path2 =
      match (path1, path2) with
        ([], []) ->
        Equal
      | (hd1 :: tl1, hd2 :: tl2) ->
        if hd1 = hd2 then
          relation_of_filename_aux tl1 tl2
        else
        begin
          NoRelation (String.compare
              (string_of_filename [hd1])
              (string_of_filename [hd2])
            )
        end
      | (_, []) -> SubDir
      | ([], _) -> UpDir
    in
    relation_of_filename_aux path1 path2

  let is_subdir path1 path2 =
    match relation_of_filename path1 path2 with
      SubDir ->
      true
    | _ ->
      false

  let is_updir path1 path2 =
    match relation_of_filename path1 path2 with
      UpDir ->
      true
    | _ ->
      false


  let compare path1 path2 =
    match relation_of_filename path1 path2 with
      SubDir -> -1
    | UpDir -> 1
    | Equal -> 0
    | NoRelation i -> i

  (* Concat *)

  let concat lst_path1 lst_path2 =
    reduce
      (match lst_path2 with
         | CurrentDir Short :: tl_path2 ->
             lst_path1 @ tl_path2
         | _ ->
             lst_path1 @ lst_path2)


  (* Is_relative *)

  let is_relative lst_path =
    match lst_path with
     (Root _) :: _ -> false
    | _            -> true


  (* Is_valid *)

  let is_valid _ =
    (* As we are manipulating abstract filename,
       and that it has been parsed, we are
       sure that all is correct *)
    true

  let is_current path =
    match path with
      [ (CurrentDir _) ] -> true
    | _ -> false

  let is_parent path =
    match path with
      [ ParentDir ] -> true
    | _ -> false

  (* Basename *)

  let basename path =
    match List.rev path with
    | hd :: _ -> [hd]
    | [] -> raise EmptyFilename

  (* Dirname *)

  let dirname path =
    match List.rev path with
    | _ :: tl -> List.rev tl
    | [] -> raise EmptyFilename

  (* Extension manipulation *)

  let wrap_extension f path =
    match basename path with
      | [Component fn] ->
          f fn
      | _ ->
          raise (NoExtension (string_of_filename path))

  let check_extension path ext =
    wrap_extension
      (fun fn -> ExtensionPath.check fn ext)
      path

  let get_extension path =
    wrap_extension
      (fun fn -> ExtensionPath.get fn)
      path

  let chop_extension path =
    wrap_extension
      (fun fn ->
         concat
           (dirname path)
           [Component (ExtensionPath.chop fn)])
      path

  let add_extension path ext =
    wrap_extension
      (fun fn ->
         concat
           (dirname path)
           [Component (ExtensionPath.add fn ext)])
      path

  let replace_extension path ext =
    wrap_extension
      (fun fn ->
         concat
           (dirname path)
           [Component (ExtensionPath.replace fn ext)])
      path

  let extension_of_string x = x

  let string_of_extension x = x

  (* Make_asbolute *)
  let make_absolute path_base path_path =
    reduce
      (if is_relative path_base then
         raise (BaseFilenameRelative (string_of_filename path_base))
       else if is_relative path_path then
         path_base @ path_path
       else
         path_path)

  (* Make_relative *)
  let make_relative path_base path_path =
    let rec make_relative_aux lst_base lst_path =
      match  (lst_base, lst_path) with
      x :: tl_base, a :: tl_path when x = a ->
        make_relative_aux tl_base tl_path
      | _, _ ->
        let back_to_base = List.rev_map
          (fun _ -> ParentDir)
          lst_base
        in
          back_to_base @ lst_path
    in
      reduce
        (if is_relative path_base then
           raise (BaseFilenameRelative (string_of_filename path_base))
         else if is_relative path_path then
           path_path
         else
           make_relative_aux path_base path_path)

  (* Make_filename *)
  let make_filename lst_path =
    reduce (List.flatten (List.map filename_of_string lst_path))

  (* Reparent *)
  let reparent path_src path_dst path =
    let path_relative =
      make_relative path_src path
    in
      make_absolute path_dst path_relative

  (* Identity *)
  let identity path = path

  (* Manipulate path like variable *)

  let string_of_path lst =
    OsOperation.path_writer (List.map string_of_filename lst)

  let path_of_string str =
    List.map
      filename_of_string
      (OsOperation.path_reader str)

  (* Generic filename component *)

  let current_dir = [ CurrentDir Long ]

  let parent_dir = [ ParentDir ]
end


(* Convert an OS_SPECIFICATION to PATH_STRING_SPECIFICATION *)
module GenericStringPath =
functor (OsOperation: OS_SPECIFICATION) ->
struct

  module Abstract = GenericPath(OsOperation)

  type filename  = string
  type extension = string

  let string_of_filename path =
    path

  let filename_of_string path =
    path

  let string_of_extension ext =
    ext

  let extension_of_string str =
    str

  let f2s = Abstract.string_of_filename

  let s2f = Abstract.filename_of_string

  let e2s = Abstract.string_of_extension

  let s2e = Abstract.extension_of_string

  let is_subdir path1 path2 =
    Abstract.is_subdir (s2f path1) (s2f path2)

  let is_updir path1 path2 =
    Abstract.is_updir  (s2f path1) (s2f path2)

  let compare path1 path2 =
    Abstract.compare   (s2f path1) (s2f path2)

  let basename path =
    try
      OsOperation.fast_basename path
    with CommonPath.CannotHandleFast ->
      f2s (Abstract.basename (s2f path))

  let dirname path =
    try
      OsOperation.fast_dirname path
    with CommonPath.CannotHandleFast ->
      f2s (Abstract.dirname  (s2f path))

  let concat path1 path2 =
    try
      OsOperation.fast_concat path1 path2
    with CommonPath.CannotHandleFast ->
      f2s (Abstract.concat (s2f path1) (s2f path2))

  let make_filename path_lst =
    f2s (Abstract.make_filename path_lst)

  let reduce ?no_symlink path =
    f2s (Abstract.reduce ?no_symlink (s2f path))

  let make_absolute base_path path =
    f2s (Abstract.make_absolute (s2f base_path) (s2f path))

  let make_relative base_path path =
    f2s (Abstract.make_relative (s2f base_path) (s2f path))

  let reparent path_src path_dst path =
    f2s (Abstract.reparent (s2f path_src)  (s2f path_dst) (s2f path))

  let identity path =
    f2s (Abstract.identity (s2f path))

  let is_valid path =
    try
      Abstract.is_valid (s2f path)
    with InvalidFilename _ ->
      false

  let is_relative path =
    try
      OsOperation.fast_is_relative path
    with CommonPath.CannotHandleFast ->
      Abstract.is_relative (s2f path)

  let is_current path =
    try
      OsOperation.fast_is_current path
    with CommonPath.CannotHandleFast ->
      Abstract.is_current (s2f path)

  let is_parent path =
    try
      OsOperation.fast_is_parent path
    with CommonPath.CannotHandleFast ->
      Abstract.is_parent (s2f path)

  let wrap_extension f path =
    let bfn =
      OsOperation.fast_basename path
    in
      if OsOperation.fast_is_parent bfn ||
         OsOperation.fast_is_current bfn ||
         not (OsOperation.fast_is_relative bfn) then
        raise (NoExtension path)
      else
        f bfn

  let chop_extension path =
    try
      wrap_extension
        (fun fn ->
           OsOperation.fast_concat
             (OsOperation.fast_dirname path)
             (ExtensionPath.chop fn))
        path
    with CommonPath.CannotHandleFast ->
      f2s (Abstract.chop_extension (s2f path))

  let get_extension path =
    try
      wrap_extension
        (fun fn -> ExtensionPath.get fn)
        path
    with CommonPath.CannotHandleFast ->
      e2s (Abstract.get_extension (s2f path))

  let check_extension path ext =
    try
      wrap_extension
        (fun fn -> ExtensionPath.check fn ext)
        path
    with CommonPath.CannotHandleFast ->
      Abstract.check_extension (s2f path) (s2e ext)

  let add_extension path ext =
    try
      wrap_extension
        (fun fn ->
           OsOperation.fast_concat
             (OsOperation.fast_dirname path)
             (ExtensionPath.add fn ext))
        path
    with CommonPath.CannotHandleFast ->
      f2s (Abstract.add_extension (s2f path) (s2e ext))

  let replace_extension path ext =
    try
      wrap_extension
        (fun fn ->
           OsOperation.fast_concat
             (OsOperation.fast_dirname path)
             (ExtensionPath.replace fn ext))
        path
    with CommonPath.CannotHandleFast ->
      f2s (Abstract.replace_extension (s2f path) (s2e ext))

  let string_of_path path_lst =
    Abstract.string_of_path (List.map s2f path_lst)

  let path_of_string str =
    List.map f2s (Abstract.path_of_string str)

  let current_dir =
    f2s (Abstract.current_dir)

  let parent_dir =
    f2s (Abstract.parent_dir)
end


module DefaultPath = GenericStringPath(struct

  let os_depend unix win32 =
    match Sys.os_type with
      "Unix"
    | "Cygwin" -> unix
    | "Win32"  -> win32
    | s        -> raise (UnrecognizedOS s)

  let dir_writer =
    os_depend
      UnixPath.dir_writer
      Win32Path.dir_writer

  let dir_reader =
    os_depend
      UnixPath.dir_reader
      Win32Path.dir_reader

  let path_writer =
    os_depend
      UnixPath.path_writer
      Win32Path.path_writer

  let path_reader =
    os_depend
      UnixPath.path_reader
      Win32Path.path_reader

  let fast_concat =
    os_depend
      UnixPath.fast_concat
      Win32Path.fast_concat

  let fast_basename =
    os_depend
      UnixPath.fast_basename
      Win32Path.fast_basename

  let fast_dirname =
    os_depend
      UnixPath.fast_dirname
      Win32Path.fast_dirname

  let fast_is_relative =
    os_depend
      UnixPath.fast_is_relative
      Win32Path.fast_is_relative

  let fast_is_current =
    os_depend
      UnixPath.fast_is_current
      Win32Path.fast_is_current

  let fast_is_parent =
    os_depend
      UnixPath.fast_is_parent
      Win32Path.fast_is_parent
end)


module UnixPath =  GenericStringPath(UnixPath)

module Win32Path = GenericStringPath(Win32Path)

module CygwinPath = UnixPath

include DefaultPath