hphp/hack/src/utils/relative_path.ml

   1 (**
   2  * Copyright (c) 2015, Facebook, Inc.
   3  * All rights reserved.
   4  *
   5  * This source code is licensed under the BSD-style license found in the
   6  * LICENSE file in the "hack" directory of this source tree. An additional grant
   7  * of patent rights can be found in the PATENTS file in the same directory.
   8  *
   9  *)
  10
  11 open Hh_core
  12 open Reordered_argument_collections
  13 open Utils
  14 open String_utils
  15
  16 type prefix =
  17   | Root
  18   | Hhi
  19   | Dummy
  20   | Tmp
  21
  22
  23 let root = ref None
  24 let hhi = ref None
  25 let tmp = ref None
  26
  27 let path_ref_of_prefix = function
  28   | Root -> root
  29   | Hhi -> hhi
  30   | Tmp -> tmp
  31   | Dummy -> ref (Some "")
  32
  33 let path_of_prefix x =
  34   unsafe_opt_note "Prefix has not been set!" !(path_ref_of_prefix x)
  35
  36 let string_of_prefix = function
  37   | Root -> "root"
  38   | Hhi -> "hhi"
  39   | Tmp -> "tmp"
  40   | Dummy -> ""
  41
  42 let set_path_prefix prefix v =
  43   let v = Path.to_string v in
  44   assert (String.length v > 0);
  45   (* Ensure that there is a trailing slash *)
  46   let v =
  47     if string_ends_with v Filename.dir_sep then v
  48     else v ^ Filename.dir_sep
  49   in
  50   match prefix with
  51   | Dummy -> raise (Failure "Dummy is always represented by an empty string")
  52   | _ -> path_ref_of_prefix prefix := Some v
  53
  54 type relative_path = prefix * string
  55 type t = relative_path
  56
  57 let prefix (p : t) = fst p
  58
  59 let suffix (p : t) = snd p
  60
  61 let default = (Dummy, "")
  62
  63 module S = struct
  64   type t = relative_path
  65
  66   let compare = Pervasives.compare
  67
  68   (* We could have simply used Marshal.to_string here, but this does slightly
  69    * better on space usage. *)
  70   let to_string (p, rest) = string_of_prefix p ^ "|" ^ rest
  71 end
  72
  73 let to_absolute (p, rest) = path_of_prefix p ^ rest
  74
  75 let to_tmp (_, rest) = (Tmp, rest)
  76
  77 let to_root (_, rest) = (Root, rest)
  78
  79 let pp fmt rp = Format.pp_print_string fmt (S.to_string rp)
  80
  81 module Set = Reordered_argument_set(Set.Make(S))
  82 module Map = Reordered_argument_map(MyMap.Make(S))
  83
  84 let create prefix s =
  85   let prefix_s = path_of_prefix prefix in
  86   let prefix_len = String.length prefix_s in
  87   if not (string_starts_with s prefix_s)
  88   then begin
  89     Printf.eprintf "%s is not a prefix of %s" prefix_s s;
  90     assert_false_log_backtrace None;
  91   end;
  92   prefix, String.sub s prefix_len (String.length s - prefix_len)
  93
  94 let from_root (s : string) : t = Root, s
  95
  96 let relativize_set prefix m =
  97   SSet.fold m ~init:Set.empty ~f:(fun k a -> Set.add a (create prefix k))
  98
  99 let set_of_list xs =
 100   List.fold_left xs ~f:Set.add ~init:Set.empty