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

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

type t_abs = abs t and t_rel = rel t and t_unk = unk t

open Am_String
  
open Am_List
  
let 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
  
let rel_of_segs segs : rel t = (`Rel, (norm1 segs))
  
let abs_of_segs segs : abs t =
  match segs with
  | "" :: segs -> (`Abs, ("" :: (norm1 segs)))
  | [] | _ :: _ -> assert false
  
let the_root : abs t = (`Abs, [ "" ])
  
(* создать путь из списка сегментов.
   для абсолютных путей может остаться "/../path",
   для относительных -- "../path".
   также возможно, что для путей вида "/a/" будет
   пустой сегмент в конце -- отрезать его не можем,
   остаётся только учитывать его при работе с путями, ниже.
 *)
let rec of_segs segs =
  match segs with
  | [] -> (rel_of_segs [] :> (* ? хз. *) unk t)
  | "" :: (("" :: _ as segs)) -> (of_segs segs :> unk t)
  | "" :: _ -> (abs_of_segs segs :> unk t)
  | segs -> (rel_of_segs segs :> unk t)
  
let segs_of_string s = String.split_exact (( = ) '/') s
  
let of_string s : unk t = of_segs (segs_of_string s)
  
let segs_to_string segs = String.concat "/" segs
  
let to_segs (_kind, segs) = segs
  
let to_string p = segs_to_string (to_segs p)
  
let abs ~base =
  function
  | ((`Abs, _p_segs) as p) -> p
  | (`Rel, p_segs) ->
      (match base with
       | (`Abs, base_segs) -> abs_of_segs (base_segs @ p_segs))
  
let not_above_root (p : abs t) =
  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
  
let root ~base p =
  match (base, p) with
  | ((`Abs, bsegs), p) ->
      (match not_above_root p with
       | (`Abs, psegs) -> abs_of_segs (bsegs @ psegs))
  
let classify =
  function | ((`Abs, _) as p) -> `Abs p | ((`Rel, _) as p) -> `Rel p
  
let map_nonempty_segs f segs =
  let rec loop segs =
    match segs with
    | [] -> []
    | h :: t -> if h = "" then loop t else (f h) :: (loop t)
  in loop segs
  
let remove_last_slash segs =
  let rec loop segs =
    match segs with | [] -> [] | [ "" ] -> [] | h :: t -> h :: (loop t)
  in loop segs
  
(*
     /a/b    /a/c -> ../c
     /a/b/   /a/c -> ../c
     /a/b    /a   -> ..

     /a      /a/c -> c
 *)
let rel_from ~base p =
  match (base, p) with
  | ((`Abs, []), _) | (_, (`Abs, [])) -> assert false
  | ((`Abs, bh :: bsegs), (`Abs, ph :: psegs)) ->
      let 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))))
      in (assert (bh = ""); assert (ph = ""); inner 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"])
    )
  )
;
*)
let append (((kind, segs) as path)) =
  function
  | "" | "." -> path
  | ".." -> raise (Invalid_argument "Filepath.append")
  | s -> (kind, (segs @ [ s ]))