home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / mosmllib / Path.mlp < prev    next >
Encoding:
Text File  |  1997-08-18  |  12.9 KB  |  398 lines  |  [TEXT/R*ch]
  1. (* Path 6 -- new basis 1995-04-28, 1995-06-06, 1996-10-13 *)
  2.  
  3. exception Path
  4.  
  5. (* It would make sense to use substrings for internal versions of
  6.  * fromString and toString, and to allocate new strings only when 
  7.  * externalizing the strings.
  8.  
  9.  * Impossible cases: 
  10.    UNIX: {isAbs = false, vol = _, arcs = "" :: _}
  11.    Mac:  {isAbs = true,  vol = _, arcs = "" :: _}
  12. *)
  13.  
  14. local 
  15.     val op @ = List.@
  16.     infix 9 sub
  17.     val op sub = String.sub
  18.     val substring = String.extract
  19.  
  20. #ifdef unix
  21. val slash = "/"
  22. val volslash = "/"
  23. fun isslash c = c = #"/"
  24. fun validVol s = s = ""
  25.  
  26. fun getVol s = 
  27.     if size s >= 1 andalso isslash (s sub 0) then SOME ""
  28.     else NONE
  29.  
  30. fun splitabsvolrest s =
  31.     if size s >= 1 andalso isslash (s sub 0) then 
  32.         (true, "", substring(s, 1, NONE))
  33.     else 
  34.         (false, "", s);    
  35. #endif
  36.  
  37. #ifdef msdos
  38. val slash = "/"
  39. val volslash = "/"
  40. fun isslash c = c = #"\\" orelse c = #"/"
  41. fun validVol s = 
  42.     size s = 0 
  43.     orelse size s >= 2 andalso Char.isAlpha (s sub 0) andalso s sub 1 = #":";
  44.         
  45. fun getVol s = 
  46.     if size s >= 2 andalso Char.isAlpha (s sub 0) andalso s sub 1 = #":" then
  47.         SOME (substring(s, 0, SOME 2))
  48.     else 
  49.         NONE;
  50.  
  51. fun splitabsvolrest s =
  52.     case getVol s of
  53.         NONE   => if size s >= 1 andalso isslash (s sub 0) then 
  54.                       (true,  "", substring(s, 1, NONE))
  55.                   else
  56.                       (false, "", s)
  57.       | SOME v => if size s >= 3 andalso isslash (s sub 2) then 
  58.                       (true,  v, substring(s, 3, NONE))
  59.                   else
  60.                       (false, v, substring(s, 2, NONE))
  61. #endif
  62.  
  63. #ifdef macintosh
  64.  
  65. (* Modified extensively for Macintosh pathnames - 1995-09-17 e *)
  66.  
  67. (* Mac pathnames differ from UNIX pathnames in many respects.
  68.    It is generally impossible to tell from the Mac pathname itself
  69.    - if the path is relative or absolute
  70.    - if the path refers to a file or directory
  71.  
  72.    Slash is spelled ":"
  73.    The root of the directory tree is referred to as "" and is an absolute
  74.    path; otherwise, any name with no colons is considered a relative path.
  75.    A name staring with a colon is always a relative path.
  76.    A name ending in a colon is always a directory path.
  77.  
  78.    There are no special file names such as "." or ".."
  79.    ":" is the current directory
  80.    "::" is up one from the current directory
  81.    ":::" is up two from the current directory, etc.
  82.    ":a::b" = ":b", "a::b:" = "b:"
  83.  
  84.    It is safer to always include a colon in the pathname if you can.
  85.    For example, instead of "foo" for a directory name
  86.                        use "foo:"  to refer to the absolute path
  87.                        use ":foo:" to refer to the relative path
  88.    even though MacOS would allow all three names for the relative path.
  89.  
  90.   A pathname without colons is consider relative. This is what one usually
  91.   wants (plain file names are looked for in the current directory first).
  92.   This leads to odd behavior; e.g., (isCanonical "a") is false, and 
  93.   (base "a.b") is ":a" -- oh well, it tends to work even if it looks weird.
  94. *)
  95.  
  96. val slash = ":"
  97. val volslash = ""
  98. val relslash = ":"
  99. fun isslash c = c = #":"
  100. fun validVol s = s = ""
  101.  
  102. (* empty name ""  => absolute
  103.    first char ":" => relative
  104.    other char ":" => absolute
  105.    else, I picked => relative
  106. *)
  107. fun splitabsvolrest s =
  108.   let val sz = size s
  109.   in
  110.     if       sz = 0           then (true,  "", s)
  111.     else if isslash (s sub 0) then (false, "", substring(s, 1, NONE))
  112.     else let fun hasslash n =
  113.            if n <= 0 then (false, "", s)
  114.            else if isslash (s sub n)
  115.                 then (true, "", s)
  116.                 else hasslash (n-1)
  117.          in hasslash (sz - 1) end
  118.   end
  119.  
  120. #endif
  121.  
  122. in
  123.  
  124. #ifdef macintosh
  125. val parentArc  = ""   (* not always! *)
  126. val currentArc = "."  (* not really! *)
  127. #else
  128. val parentArc  = ".."
  129. val currentArc = "."
  130. #endif
  131.  
  132. fun isAbsolute p = #1 (splitabsvolrest p)
  133.  
  134. fun isRelative p = not (isAbsolute p);
  135.  
  136. fun fromString p = 
  137.     case splitabsvolrest p of
  138. #ifdef macintosh
  139.         (true,  v,   "") => {isAbs=true,  vol = v, arcs = []}
  140. #else
  141.         (false, v,   "") => {isAbs=false, vol = v, arcs = []}
  142. #endif
  143.       | (isAbs, v, rest) => {isAbs=isAbs, vol = v, 
  144.                              arcs = String.fields isslash rest};
  145.  
  146. fun isRoot p = 
  147.     case splitabsvolrest p of
  148.         (true, _, "") => true
  149.       | _             => false;
  150.  
  151. fun getVolume p = #2 (splitabsvolrest p);
  152. fun validVolume{isAbs, vol} = validVol vol;
  153.  
  154. fun toString (path as {isAbs, vol, arcs}) =
  155.     let fun h []        res = res 
  156.           | h (a :: ar) res = h ar (a :: slash :: res)
  157.     in  
  158.         if validVolume{isAbs=isAbs, vol=vol} then 
  159.             case (isAbs, arcs) of
  160. #ifdef macintosh
  161.                 (false, []         ) => vol ^ relslash
  162.               | (false, [a]        ) => (* special case for simple filenames *)
  163.                                         if a = "" then ":" else a
  164.               | (false, a1 :: arest) => 
  165.                     String.concat (List.rev (h arest [a1, relslash, vol]))
  166. #else
  167.                 (false, []         ) => vol
  168.               | (false, "" :: _    ) => raise Path
  169.               | (false, a1 :: arest) => 
  170.                     String.concat (vol :: List.rev (h arest [a1]))
  171. #endif
  172.               | (true,  []         ) => vol ^ volslash
  173.               | (true, a1 :: arest ) => 
  174.                     String.concat (List.rev (h arest [a1, volslash, vol])) 
  175.         else
  176.             raise Path
  177.     end;
  178.  
  179. #ifdef macintosh
  180. fun concat (p1, p2) =
  181.     let fun stripslash path = 
  182.             let val sz = size path
  183.             in if sz > 0 andalso isslash (path sub (sz - 1)) then
  184.                    substring(path, 0, SOME(sz - 1))
  185.                else path
  186.             end
  187.         val p2' = 
  188.             if size p2 > 0 andalso isslash (p2 sub 0)
  189.             then substring(p2, 1, NONE)
  190.             else p2
  191.     in
  192.         if p2 <> "" andalso isAbsolute p2 then raise Path
  193.         else
  194.             case splitabsvolrest p1 of
  195.                 (false, "",   "") =>     relslash ^ p2'
  196.               | (false, v,  path) => v ^ relslash ^ stripslash path ^ slash ^ p2'
  197.               | (true,  v,  ""  ) => v ^ volslash ^ p2'
  198.               | (true,  v,  path) => v ^ volslash ^ stripslash path ^ slash ^ p2'
  199.     end;
  200. #else
  201. fun concat (p1, p2) =
  202.     let fun stripslash path = 
  203.             if isslash (path sub (size path - 1)) then
  204.                 substring(path, 0, SOME(size path - 1))
  205.             else path
  206.     in
  207.         if isAbsolute p2 then raise Path
  208.         else
  209.             case splitabsvolrest p1 of
  210.                 (false, "",   "") => p2
  211.               | (false, v,  path) => v ^ stripslash path ^ slash ^ p2
  212.               | (true,  v,  ""  ) => v ^ volslash ^ p2
  213.               | (true,  v,  path) => v ^ volslash ^ stripslash path ^ slash ^ p2
  214.     end;
  215. #endif
  216.  
  217. #ifdef macintosh
  218. fun getParent p =
  219.     let open List
  220.         fun getpar xs = 
  221.             rev (case rev xs of
  222.                      []                  => []         
  223.                    | "" :: "" :: revrest => "" :: "" :: "" :: revrest
  224.                    | "" ::  _ :: revrest => "" :: revrest
  225.                    |       "" ::      [] => ["",""]
  226.                    |        _ :: revrest => "" :: revrest)
  227.         val {isAbs, vol, arcs} = fromString p 
  228.     in
  229.         case getpar arcs of 
  230.             []   => 
  231.                 if isAbs then toString {isAbs=true, vol=vol, arcs=[]}
  232.                 else ":"
  233.           | arcs => toString {isAbs=isAbs, vol=vol, arcs=arcs}
  234.     end;
  235. #else
  236. fun getParent p =
  237.     let open List
  238.     val {isAbs, vol, arcs} = fromString p 
  239.     fun getpar xs = 
  240.         rev (case rev xs of
  241.              []              => [parentArc]
  242.            | [""]            => if isAbs then [] else [parentArc]
  243.            | ""   :: revrest => parentArc :: revrest
  244.            | "."  :: revrest => parentArc :: revrest
  245.            | ".." :: revrest => parentArc :: parentArc :: revrest
  246.            | last :: revrest => revrest)
  247.     in
  248.         case getpar arcs of 
  249.             []   => 
  250.                 if isAbs then toString {isAbs=true, vol=vol, arcs=[""]}
  251.                 else currentArc
  252.           | arcs => toString {isAbs=isAbs, vol=vol, arcs=arcs}
  253.     end;
  254. #endif
  255.  
  256. #ifdef macintosh
  257. fun canonize p =
  258.     let val {isAbs, vol, arcs} = fromString p 
  259.         fun lastup []                 = if isAbs then [] else [""]
  260.           | lastup ( "" :: res) = "" :: "" :: res
  261.           | lastup (       res) = "" :: res
  262.         fun backup []                 = if isAbs then [] else [""]
  263.           | backup ( "" :: res) = "" :: "" :: res
  264.           | backup ( _  :: res) = res
  265.         fun reduce arcs = 
  266.             let fun h []           []  = if isAbs then [] else [""]
  267.                   | h []           res =             res
  268.                   | h (""::[])     res =      (lastup res)
  269.                   | h (""::ar)     res = h ar (backup res)
  270.                   | h (a1::ar)     res = h ar (a1 :: res)
  271.             in h arcs [] end
  272.     in
  273.         {isAbs=isAbs, vol=vol, arcs=List.rev (reduce arcs)}
  274.     end;
  275.  
  276. fun mkCanonical p = toString (canonize p);
  277. #else
  278. fun mkCanonical p =
  279.     let val {isAbs, vol, arcs} = fromString p 
  280.         fun backup []          = if isAbs then [] else [parentArc]
  281.           | backup (".."::res) = parentArc :: parentArc :: res
  282.           | backup ( _ :: res) = res
  283.         fun reduce arcs = 
  284.             let fun h []         []  = if isAbs then [""] else [currentArc]
  285.                   | h []         res = res
  286.                   | h (""::ar)   res = h ar res
  287.                   | h ("."::ar)  res = h ar res
  288.                   | h (".."::ar) res = h ar (backup res)
  289.                   | h (a1::ar)   res = h ar (a1 :: res)
  290.             in h arcs [] end
  291.     in
  292.         toString {isAbs=isAbs, vol=vol, arcs=List.rev (reduce arcs)}
  293.     end;
  294. #endif
  295.  
  296. #ifdef macintosh
  297. fun parentize      []  = []
  298.   | parentize (""::[]) = []
  299.   | parentize (_ ::ar) = "" :: parentize ar;
  300.  
  301. fun parentize' ar = "" :: parentize ar;
  302.  
  303. fun mkRelative (p1, p2) =
  304.     case (fromString p1, canonize p2) of
  305.         (_ ,                {isAbs=false,...}) => raise Path
  306.       | ({isAbs=false,...}, _                ) => p1
  307.       | ({vol=vol1, arcs=arcs1,...}, {vol=vol2, arcs=arcs2, ...}) =>
  308.             let fun h []      []  = [""]
  309.                   | h a1      []  = a1
  310.                   | h a1 (""::[]) = a1
  311.                   | h (""::[]) a2 = parentize' a2
  312.                   | h      []  a2 = parentize' a2
  313.                   | h (a1 as (a11::a1r)) (a2 as (a21::a2r)) =
  314.                     if a11=a21 then h a1r a2r
  315.                     else parentize a2 @ a1
  316.             in
  317.                 if vol1 <> vol2 then raise Path 
  318.                 else toString {isAbs=false, vol="", arcs=h arcs1 arcs2}
  319.             end;
  320. #else
  321. fun parentize []      = []
  322.   | parentize (_::ar) = parentArc :: parentize ar;
  323.  
  324. fun mkRelative (p1, p2) =
  325.     case (fromString p1, fromString (mkCanonical p2)) of
  326.         (_ ,                {isAbs=false,...}) => raise Path
  327.       | ({isAbs=false,...}, _                ) => p1
  328.       | ({vol=vol1, arcs=arcs1,...}, {vol=vol2, arcs=arcs2, ...}) =>
  329.             let fun h [] [] = ["."]
  330.                   | h a1 [] = a1
  331.                   | h [] a2 = parentize a2
  332.                   | h (a1 as (a11::a1r)) (a2 as (a21::a2r)) =
  333.                     if a11=a21 then h a1r a2r
  334.                     else parentize a2 @ (if arcs1 = [""] then [] else a1)
  335.             in
  336.                 if vol1 <> vol2 then raise Path 
  337.                 else toString {isAbs=false, vol="", arcs=h arcs1 arcs2}
  338.             end;
  339. #endif
  340.  
  341. fun mkAbsolute (p1, p2) =
  342.     if isRelative p2 then raise Path
  343.     else if isAbsolute p1 then p1
  344.     else mkCanonical(concat(p2, p1));
  345.  
  346. fun isCanonical p = mkCanonical p = p;
  347.  
  348. fun joinDirFile {dir, file} = concat(dir, file)
  349.  
  350. fun splitDirFile p =
  351.     let open List
  352.         val {isAbs, vol, arcs} = fromString p 
  353.     in
  354.         case rev arcs of
  355.             []            => 
  356.                 {dir = toString {isAbs=isAbs, vol=vol, arcs=[]}, file = ""  }
  357. #ifdef macintosh
  358.           | "" :: _       => 
  359.                 {dir = toString {isAbs=isAbs, vol=vol, arcs=arcs}, file = ""}
  360.           | arcn :: [] => 
  361.                 {dir = "", file = arcn}
  362.           | arcn :: farcs => 
  363.                 {dir = toString {isAbs=isAbs, vol=vol, arcs=rev ("" :: farcs)}, 
  364.                  file = arcn}
  365. #else
  366.           | arcn :: farcs => 
  367.                 {dir = toString {isAbs=isAbs, vol=vol, arcs=rev farcs}, 
  368.                  file = arcn}
  369. #endif
  370.     end
  371.  
  372. fun dir s  = #dir (splitDirFile s);
  373. fun file s = #file(splitDirFile s);
  374.  
  375. fun joinBaseExt {base, ext = NONE}    = base
  376.   | joinBaseExt {base, ext = SOME ""} = base
  377.   | joinBaseExt {base, ext = SOME ex} = base ^ "." ^ ex;
  378.  
  379. fun splitBaseExt s =
  380.     let val {dir, file} = splitDirFile s
  381.         open Substring 
  382.         val (fst, snd) = splitr (fn c => c <> #".") (all file)
  383.     in 
  384.         if isEmpty snd         (* dot at right end     *) 
  385.            orelse isEmpty fst  (* no dot               *)
  386.            orelse size fst = 1 (* dot at left end only *) 
  387.             then {base = s, ext = NONE}
  388.         else 
  389.             {base = joinDirFile{dir = dir, 
  390.                                 file = string (trimr 1 fst)},
  391.              ext = SOME (string snd)}
  392.     end;
  393.  
  394. fun ext s  = #ext  (splitBaseExt s);
  395. fun base s = #base (splitBaseExt s);
  396.  
  397. end
  398.