(* Path 6 -- new basis 1995-04-28, 1995-06-06, 1996-10-13 *)

exception Path

(* It would make sense to use substrings for internal versions of
 * fromString and toString, and to allocate new strings only when 
 * externalizing the strings.

 * Impossible cases: 
   UNIX: {isAbs = false, vol = _, arcs = "" :: _}
   Mac:  {isAbs = true,  vol = _, arcs = "" :: _}
*)

local 
    val op @ = List.@
    infix 9 sub
    val op sub = String.sub
    val substring = String.extract

#ifdef unix
val slash = "/"
val volslash = "/"
fun isslash c = c = #"/"
fun validVol s = s = ""

fun getVol s = 
    if size s >= 1 andalso isslash (s sub 0) then SOME ""
    else NONE

fun splitabsvolrest s =
    if size s >= 1 andalso isslash (s sub 0) then 
        (true, "", substring(s, 1, NONE))
    else 
        (false, "", s);    
#endif

#if defined(msdos) || defined(win32)
val slash = "/"
val volslash = "/"
fun isslash c = c = #"\\" orelse c = #"/"
fun validVol s = 
    size s = 0 
    orelse size s >= 2 andalso Char.isAlpha (s sub 0) andalso s sub 1 = #":";
        
fun getVol s = 
    if size s >= 2 andalso Char.isAlpha (s sub 0) andalso s sub 1 = #":" then
        SOME (substring(s, 0, SOME 2))
    else 
        NONE;

fun splitabsvolrest s =
    case getVol s of
        NONE   => if size s >= 1 andalso isslash (s sub 0) then 
                      (true,  "", substring(s, 1, NONE))
                  else
                      (false, "", s)
      | SOME v => if size s >= 3 andalso isslash (s sub 2) then 
                      (true,  v, substring(s, 3, NONE))
                  else
                      (false, v, substring(s, 2, NONE))
#endif

#ifdef macintosh

(* Modified extensively for Macintosh pathnames - 1995-09-17 e *)

(* Mac pathnames differ from UNIX pathnames in many respects.
   It is generally impossible to tell from the Mac pathname itself
   - if the path is relative or absolute
   - if the path refers to a file or directory

   Slash is spelled ":"
   The root of the directory tree is referred to as "" and is an absolute
   path; otherwise, any name with no colons is considered a relative path.
   A name staring with a colon is always a relative path.
   A name ending in a colon is always a directory path.

   There are no special file names such as "." or ".."
   ":" is the current directory
   "::" is up one from the current directory
   ":::" is up two from the current directory, etc.
   ":a::b" = ":b", "a::b:" = "b:"

   It is safer to always include a colon in the pathname if you can.
   For example, instead of "foo" for a directory name
                       use "foo:"  to refer to the absolute path
                       use ":foo:" to refer to the relative path
   even though MacOS would allow all three names for the relative path.

  A pathname without colons is consider relative. This is what one usually
  wants (plain file names are looked for in the current directory first).
  This leads to odd behavior; e.g., (isCanonical "a") is false, and 
  (base "a.b") is ":a" -- oh well, it tends to work even if it looks weird.
*)

val slash = ":"
val volslash = ""
val relslash = ":"
fun isslash c = c = #":"
fun validVol s = s = ""

(* empty name ""  => absolute
   first char ":" => relative
   other char ":" => absolute
   else, I picked => relative
*)
fun splitabsvolrest s =
  let val sz = size s
  in
    if       sz = 0           then (true,  "", s)
    else if isslash (s sub 0) then (false, "", substring(s, 1, NONE))
    else let fun hasslash n =
           if n <= 0 then (false, "", s)
           else if isslash (s sub n)
                then (true, "", s)
                else hasslash (n-1)
         in hasslash (sz - 1) end
  end

#endif

in

#ifdef macintosh
val parentArc  = ""   (* not always! *)
val currentArc = "."  (* not really! *)
#else
val parentArc  = ".."
val currentArc = "."
#endif

fun isAbsolute p = #1 (splitabsvolrest p)

fun isRelative p = not (isAbsolute p);

fun fromString p = 
    case splitabsvolrest p of
#ifdef macintosh
        (true,  v,   "") => {isAbs=true,  vol = v, arcs = []}
#else
        (false, v,   "") => {isAbs=false, vol = v, arcs = []}
#endif
      | (isAbs, v, rest) => {isAbs=isAbs, vol = v, 
                             arcs = String.fields isslash rest};

fun isRoot p = 
    case splitabsvolrest p of
        (true, _, "") => true
      | _             => false;

fun getVolume p = #2 (splitabsvolrest p);
fun validVolume{isAbs, vol} = validVol vol;

fun toString (path as {isAbs, vol, arcs}) =
    let fun h []        res = res 
          | h (a :: ar) res = h ar (a :: slash :: res)
    in  
        if validVolume{isAbs=isAbs, vol=vol} then 
            case (isAbs, arcs) of
#ifdef macintosh
                (false, []         ) => vol ^ relslash
              | (false, [a]        ) => (* special case for simple filenames *)
                                        if a = "" then ":" else a
              | (false, a1 :: arest) => 
                    String.concat (List.rev (h arest [a1, relslash, vol]))
#else
                (false, []         ) => vol
              | (false, "" :: _    ) => raise Path
              | (false, a1 :: arest) => 
                    String.concat (vol :: List.rev (h arest [a1]))
#endif
              | (true,  []         ) => vol ^ volslash
              | (true, a1 :: arest ) => 
                    String.concat (List.rev (h arest [a1, volslash, vol])) 
        else
            raise Path
    end;

#ifdef macintosh
fun concat (p1, p2) =
    let fun stripslash path = 
            let val sz = size path
            in if sz > 0 andalso isslash (path sub (sz - 1)) then
                   substring(path, 0, SOME(sz - 1))
               else path
            end
        val p2' = 
            if size p2 > 0 andalso isslash (p2 sub 0)
            then substring(p2, 1, NONE)
            else p2
    in
        if p2 <> "" andalso isAbsolute p2 then raise Path
        else
            case splitabsvolrest p1 of
                (false, "",   "") =>     relslash ^ p2'
              | (false, v,  path) => v ^ relslash ^ stripslash path ^ slash ^ p2'
              | (true,  v,  ""  ) => v ^ volslash ^ p2'
              | (true,  v,  path) => v ^ volslash ^ stripslash path ^ slash ^ p2'
    end;
#else
fun concat (p1, p2) =
    let fun stripslash path = 
            if isslash (path sub (size path - 1)) then
                substring(path, 0, SOME(size path - 1))
            else path
    in
        if isAbsolute p2 then raise Path
        else
            case splitabsvolrest p1 of
                (false, "",   "") => p2
              | (false, v,  path) => v ^ stripslash path ^ slash ^ p2
              | (true,  v,  ""  ) => v ^ volslash ^ p2
              | (true,  v,  path) => v ^ volslash ^ stripslash path ^ slash ^ p2
    end;
#endif

#ifdef macintosh
fun getParent p =
    let open List
        fun getpar xs = 
            rev (case rev xs of
                     []                  => []         
                   | "" :: "" :: revrest => "" :: "" :: "" :: revrest
                   | "" ::  _ :: revrest => "" :: revrest
                   |       "" ::      [] => ["",""]
                   |        _ :: revrest => "" :: revrest)
        val {isAbs, vol, arcs} = fromString p 
    in
        case getpar arcs of 
            []   => 
                if isAbs then toString {isAbs=true, vol=vol, arcs=[]}
                else ":"
          | arcs => toString {isAbs=isAbs, vol=vol, arcs=arcs}
    end;
#else
fun getParent p =
    let open List
	val {isAbs, vol, arcs} = fromString p 
	fun getpar xs = 
	    rev (case rev xs of
		     []              => [parentArc]
		   | [""]            => if isAbs then [] else [parentArc]
		   | ""   :: revrest => parentArc :: revrest
		   | "."  :: revrest => parentArc :: revrest
		   | ".." :: revrest => parentArc :: parentArc :: revrest
		   | last :: revrest => revrest)
    in
        case getpar arcs of 
            []   => 
                if isAbs then toString {isAbs=true, vol=vol, arcs=[""]}
                else currentArc
          | arcs => toString {isAbs=isAbs, vol=vol, arcs=arcs}
    end;
#endif

#ifdef macintosh
fun canonize p =
    let val {isAbs, vol, arcs} = fromString p 
        fun lastup []                 = if isAbs then [] else [""]
          | lastup ( "" :: res) = "" :: "" :: res
          | lastup (       res) = "" :: res
        fun backup []                 = if isAbs then [] else [""]
          | backup ( "" :: res) = "" :: "" :: res
          | backup ( _  :: res) = res
        fun reduce arcs = 
            let fun h []           []  = if isAbs then [] else [""]
                  | h []           res =             res
                  | h (""::[])     res =      (lastup res)
                  | h (""::ar)     res = h ar (backup res)
                  | h (a1::ar)     res = h ar (a1 :: res)
            in h arcs [] end
    in
        {isAbs=isAbs, vol=vol, arcs=List.rev (reduce arcs)}
    end;

fun mkCanonical p = toString (canonize p);
#else
fun mkCanonical p =
    let val {isAbs, vol, arcs} = fromString p 
        fun backup []          = if isAbs then [] else [parentArc]
          | backup (".."::res) = parentArc :: parentArc :: res
          | backup ( _ :: res) = res
        fun reduce arcs = 
            let fun h []         []  = if isAbs then [""] else [currentArc]
                  | h []         res = res
                  | h (""::ar)   res = h ar res
                  | h ("."::ar)  res = h ar res
                  | h (".."::ar) res = h ar (backup res)
                  | h (a1::ar)   res = h ar (a1 :: res)
            in h arcs [] end
    in
        toString {isAbs=isAbs, vol=vol, arcs=List.rev (reduce arcs)}
    end;
#endif

#ifdef macintosh
fun parentize      []  = []
  | parentize (""::[]) = []
  | parentize (_ ::ar) = "" :: parentize ar;

fun parentize' ar = "" :: parentize ar;

fun mkRelative (p1, p2) =
    case (fromString p1, canonize p2) of
        (_ ,                {isAbs=false,...}) => raise Path
      | ({isAbs=false,...}, _                ) => p1
      | ({vol=vol1, arcs=arcs1,...}, {vol=vol2, arcs=arcs2, ...}) =>
            let fun h []      []  = [""]
                  | h a1      []  = a1
                  | h a1 (""::[]) = a1
                  | h (""::[]) a2 = parentize' a2
                  | h      []  a2 = parentize' a2
                  | h (a1 as (a11::a1r)) (a2 as (a21::a2r)) =
                    if a11=a21 then h a1r a2r
                    else parentize a2 @ a1
            in
                if vol1 <> vol2 then raise Path 
                else toString {isAbs=false, vol="", arcs=h arcs1 arcs2}
            end;
#else
fun parentize []      = []
  | parentize (_::ar) = parentArc :: parentize ar;

fun mkRelative (p1, p2) =
    case (fromString p1, fromString (mkCanonical p2)) of
        (_ ,                {isAbs=false,...}) => raise Path
      | ({isAbs=false,...}, _                ) => p1
      | ({vol=vol1, arcs=arcs1,...}, {vol=vol2, arcs=arcs2, ...}) =>
            let fun h [] [] = ["."]
                  | h a1 [] = a1
                  | h [] a2 = parentize a2
                  | h (a1 as (a11::a1r)) (a2 as (a21::a2r)) =
                    if a11=a21 then h a1r a2r
                    else parentize a2 @ (if arcs1 = [""] then [] else a1)
            in
                if vol1 <> vol2 then raise Path 
                else toString {isAbs=false, vol="", arcs=h arcs1 arcs2}
            end;
#endif

fun mkAbsolute (p1, p2) =
    if isRelative p2 then raise Path
    else if isAbsolute p1 then p1
    else mkCanonical(concat(p2, p1));

fun isCanonical p = mkCanonical p = p;

fun joinDirFile {dir, file} = concat(dir, file)

fun splitDirFile p =
    let open List
        val {isAbs, vol, arcs} = fromString p 
    in
        case rev arcs of
            []            => 
                {dir = toString {isAbs=isAbs, vol=vol, arcs=[]}, file = ""  }
#ifdef macintosh
          | "" :: _       => 
                {dir = toString {isAbs=isAbs, vol=vol, arcs=arcs}, file = ""}
          | arcn :: [] => 
                {dir = "", file = arcn}
          | arcn :: farcs => 
                {dir = toString {isAbs=isAbs, vol=vol, arcs=rev ("" :: farcs)}, 
                 file = arcn}
#else
          | arcn :: farcs => 
                {dir = toString {isAbs=isAbs, vol=vol, arcs=rev farcs}, 
                 file = arcn}
#endif
    end

fun dir s  = #dir (splitDirFile s);
fun file s = #file(splitDirFile s);

fun joinBaseExt {base, ext = NONE}    = base
  | joinBaseExt {base, ext = SOME ""} = base
  | joinBaseExt {base, ext = SOME ex} = base ^ "." ^ ex;

fun splitBaseExt s =
    let val {dir, file} = splitDirFile s
        open Substring 
        val (fst, snd) = splitr (fn c => c <> #".") (all file)
    in 
        if isEmpty snd         (* dot at right end     *) 
           orelse isEmpty fst  (* no dot               *)
           orelse size fst = 1 (* dot at left end only *) 
            then {base = s, ext = NONE}
        else 
            {base = joinDirFile{dir = dir, 
                                file = string (trimr 1 fst)},
             ext = SOME (string snd)}
    end;

fun ext s  = #ext  (splitBaseExt s);
fun base s = #base (splitBaseExt s);

end