Source file fs_types.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2022 DaiLambda, Inc. <contact@dailambda.jp>                 *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Name = struct
  (** File name : ex "tmp" *)
  type t = string

  let equal (t1 : string) t2 = t1 = t2

  let to_string t = t

  let pp = Format.pp_print_string
end

module Path = struct
  (** Path name : ex "tmp/file".
      No notion of absolute/relative paths *)
  type name = Name.t

  type t = Name.t list

  let length = List.length

  let rec equal ns1 ns2 = match ns1, ns2 with
    | [], [] -> true
    | n1::ns1, n2::ns2 when Name.equal n1 n2 -> equal ns1 ns2
    | _ -> false

  let to_string t =
    match t with
    | [] -> "empty_path"
    | _ -> String.concat "/" (List.map Name.to_string t)

  let pp ppf t = Format.pp_print_string ppf @@ to_string t

  let is_prefix_of p1 p2 =
    let rec f p1 p2 =
      match p1, p2 with
      | [], _ -> Some p2
      | n1::p1, n2::p2 when Name.equal n1 n2 -> f p1 p2
      | _ -> None
    in
    f p1 p2
end

module FsError = struct
  type path = Path.t

  (** File system errors *)
  type t =
    | Is_file of string * path
    | Is_directory of string * path
    | No_such_file_or_directory of string * path
    | File_or_directory_exists of string * path
    | Path_decode_failure of Segment.t
    | No_pagination_count
    | Other of string * string

  type Error.t += FS_error of t

  let () =
    Error.register_printer
    @@ function
    | FS_error e ->
        Some
          ( match e with
            | Is_file (op, path) ->
                Format.asprintf "%s: it is a file: %a" op Path.pp path
            | Is_directory (op, path) ->
                Format.asprintf "%s: it is a directory: %a" op Path.pp path
            | No_such_file_or_directory (op, path) ->
                Format.asprintf
                  "%s: no such file or directory: %a"
                  op
                  Path.pp path
            | File_or_directory_exists (op, path) ->
                Format.asprintf
                  "%s: file or directory exists: %a"
                  op
                  Path.pp path
            | Path_decode_failure seg ->
                Format.asprintf
                  "path decode failure: %a" Segment.pp seg
            | No_pagination_count -> "No pagination count"
            | Other (n, mes) ->
                Format.asprintf "%s: %s" n mes
          )
    | _ ->
        None

  let error e = Error (FS_error e)
end

(** Module type for file name encoding to segments

    We have several implementations of name encodings in fs_nameenc_impl.ml
*)
module type NAMEENC = sig
  type name = Name.t

  val to_segment : name -> Segment.t
  val of_segment : Segment.t -> name option
end