amall / src / filepath.ml

type abs = [= `Abs ]
 and rel = [= `Rel ]
 and unk = [= `Abs | `Rel ]
;


(* инварианты:
   - kind=`Abs => список начинается с пустого сегмента (ибо "/a/b")
   - за исключением первого и последнего компонента пустых сегментов нет
   - сегментов "." нет
   - все сегменты ".." нормализованы ровно настолько, насколько
     это возможно: а именно, могут идти только в начале пути
 *)

type t +'kind = ('kind * list string)
;


open Am_String
;
open Am_List
;


value rec norm1 ?(acc=[]) segs =
    match segs with
    [ [] -> List.rev acc
    | [("" as h) :: ([] as t)] -> norm1 ~acc:[h :: acc] t
    | [("" | ".") :: segs] -> norm1 ~acc segs
    | [(".." as seg) :: segs] ->
        match acc with
        [ [] | [".." :: _] -> norm1 ~acc:[seg :: acc] segs
        | [_ :: acc_tl] -> norm1 ~acc:acc_tl segs
        ]
    | [h :: t] -> norm1 ~acc:[h :: acc] t
    ]
;


value rel_of_segs segs : t rel =
  (`Rel, norm1 segs)
;


value abs_of_segs segs : t abs =
  match segs with
  [ ["" :: segs] -> (`Abs, ["" :: norm1 segs])
  | [] | [_ :: _] -> assert False
  ]
;


(* создать путь из списка сегментов.
   для абсолютных путей может остаться "/../path",
   для относительных -- "../path".
   также возможно, что для путей вида "/a/" будет
   пустой сегмент в конце -- отрезать его не можем,
   остаётся только учитывать его при работе с путями, ниже.
 *)

value rec of_segs segs =
  match segs with
  [ [] -> ((rel_of_segs [] (* ? хз. *) ) :> t unk)
  | ["" :: (["" :: _] as segs)] -> ((of_segs segs) :> t unk)
  | ["" :: _] -> ((abs_of_segs segs) :> t unk)
  | segs -> ((rel_of_segs segs) :> t unk)
  ]
;


value of_string s : t unk =
  of_segs (String.split_exact ( (=) '/' ) s)
;


value segs_to_string segs =
  String.concat "/" segs
;


value to_segs (_kind, segs) =
  segs
;


value to_string p =
  segs_to_string (to_segs p)
;




value abs ~base = fun
  [ (`Abs, _p_segs) as p -> p
  | (`Rel, p_segs) ->
      match base with
      [ (`Abs, base_segs) ->
          abs_of_segs (base_segs @ p_segs)
      ]
  ]
;


value not_above_root (p : t abs) =
  match p with
  [ (`Abs, [ph :: pt]) ->
      let () = assert (ph = "") in
      let pt' = List.drop_while ((=) "..") pt in
      if pt == pt'
      then p
      else (`Abs, ["" :: pt'])
  | (`Abs, []) ->
      assert False
  ]
;


value root ~base p =
  match (base, p) with
  [ ((`Abs, bsegs), p) ->
      match not_above_root p with
      [ (`Abs, psegs) ->
          abs_of_segs (bsegs @ psegs)
      ]
  ]
;


value classify = fun
  [ (`Abs, _) as p -> `Abs p
  | (`Rel, _) as p -> `Rel p
  ]
;


value map_nonempty_segs f segs =
  loop segs
  where rec loop segs =
    match segs with
    [ [] -> []
    | [h :: t] ->
        if h = ""
        then loop t
        else [f h :: loop t]
    ]
;


value remove_last_slash segs =
  loop segs
  where rec loop segs =
    match segs with
    [ [] -> []
    | ["" :: []] -> []
    | [h :: t] -> [h :: loop t]
    ]
;


(*
     /a/b    /a/c -> ../c
     /a/b/   /a/c -> ../c
     /a/b    /a   -> ..

     /a      /a/c -> c
 *)


value rel_from ~base p =
  match (base, p) with
  [ ((`Abs, []), _) | (_, (`Abs, [])) ->
      assert False
  | ((`Abs, [bh :: bsegs]), (`Abs, [ph :: psegs])) ->
      ( assert (bh = "")
      ; assert (ph = "")
      ; inner bsegs psegs
      )
      where rec inner bsegs psegs =
        (* let () = Printf.printf "b=%S p=%S\n%!" (segs_to_string bsegs)
          (segs_to_string psegs) in *)
        match bsegs with
        [ ([] | ["" :: []]) ->
            (`Rel, psegs)
        | [bh :: bt] ->
            match psegs with
            [ [ph :: pt] when bh = ph ->
                inner bt pt
            | [] | [_ :: _] ->
                (`Rel, (map_nonempty_segs (fun _ -> "..") bsegs) @ psegs)
            ]
        ]
  ]
;


(*
value () =
  let r = (rel_from ~base:(`Abs, [""; "a"; "b"; ""]) (`Abs, [""; "a"; "c"])) in
  Printf.printf "r=%S\n" (to_string r)
  Printf.printf "%b" (
    ( 
    = (`Rel, [".."; "c"])
    )
  )
;
*)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.