Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/smlnj-lib/Util/getopt.sml
ViewVC logotype

Diff of /sml/trunk/src/smlnj-lib/Util/getopt.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1771, Thu Mar 17 22:53:15 2005 UTC revision 1772, Mon Mar 21 19:45:03 2005 UTC
# Line 29  Line 29 
29    
30      datatype 'a opt_kind      datatype 'a opt_kind
31        = Opt of 'a        = Opt of 'a
32        | NonOpt of string        | NonOpt
       | EndOfOpts  
33    
34      structure SS = Substring      structure SS = Substring
35      structure S = String      structure S = String
# Line 103  Line 102 
102          (* handle long option          (* handle long option
103           * this is messy because you cannot pattern-match on substrings           * this is messy because you cannot pattern-match on substrings
104           *)           *)
105            fun longOpt (subs, rest, optDescr : 'a opt_descr list) = let            fun longOpt (subs, rest) = let
106                  val (opt,arg) = breakeq subs                  val (opt,arg) = breakeq subs
107                  val opt' = SS.string opt                  val opt' = SS.string opt
108                  val options = List.filter                  val options = List.filter
109                        (fn {long,...} => List.exists (S.isPrefix opt') long)                        (fn {long,...} => List.exists (S.isPrefix opt') long)
110                          optDescr                          options
111                  val optStr = "--"^opt'                  val optStr = "--"^opt'
112                  fun long (_::(_::_), _, rest') = (                  fun long (_::(_::_), _, rest') = (
113                        errAmbig optStr; (NonOpt optStr, rest'))                        errAmbig optStr; (NonOpt, rest'))
114                    | long ([NoArg a], x, rest') =                    | long ([NoArg a], x, rest') =
115                        if (SS.isEmpty x)                        if (SS.isEmpty x)
116                          then (Opt(a()),rest')                          then (Opt(a()),rest')
117                        else if (SS.isPrefix "=" x)                        else if (SS.isPrefix "=" x)
118                          then (errNoArg optStr; (NonOpt optStr, rest'))                          then (errNoArg optStr; (NonOpt, rest'))
119                          else raise Fail "long: impossible"                          else raise Fail "long: impossible"
120                    | long ([ReqArg(f,d)], x, []) =                    | long ([ReqArg(f,d)], x, []) =
121                        if (SS.isEmpty x)                        if (SS.isEmpty x)
122                          then (errReq(d, optStr); (NonOpt optStr, []))                          then (errReq(d, optStr); (NonOpt, []))
123                        else if (SS.isPrefix "=" x)                        else if (SS.isPrefix "=" x)
124                          then (Opt(f (SS.string (SS.triml 1 x))), [])                          then (Opt(f (SS.string (SS.triml 1 x))), [])
125                          else raise Fail "long: impossible"                          else raise Fail "long: impossible"
# Line 137  Line 136 
136                          then (Opt(f (SOME (SS.string (SS.triml 1 x)))), rest')                          then (Opt(f (SOME (SS.string (SS.triml 1 x)))), rest')
137                          else raise Fail "long: impossible"                          else raise Fail "long: impossible"
138                    | long ([], _, rest') = (                    | long ([], _, rest') = (
139                        errUnrec optStr; (NonOpt optStr, rest'))                        errUnrec optStr; (NonOpt, rest'))
140                  in                  in
141                    long (map #desc options, arg, rest)                    long (map #desc options, arg, rest)
142                  end                  end
# Line 145  Line 144 
144           * rest of the option string, rest is the rest of the command-line           * rest of the option string, rest is the rest of the command-line
145           * options.           * options.
146           *)           *)
147            fun shortOpt (x, subs, rest, optDescr : 'a opt_descr list) = let            fun shortOpt (x, subs, rest) = let
148                  val options =                  val options =
149                        List.filter (fn {short,...} => Char.contains short x) optDescr                        List.filter (fn {short,...} => Char.contains short x) options
150                  val ads = map #desc options                  val ads = map #desc options
151                  val optStr = "-"^(str x)                  val optStr = "-"^(str x)
152                  in                  in
153                    case (ads, rest)                    case (ads, rest)
154                     of (_::_::_, rest1) => (errAmbig optStr; (NonOpt optStr, rest1))                     of (_::_::_, rest1) => (errAmbig optStr; (NonOpt, rest1))
155                      | ((NoArg a)::_, rest') =>                      | ((NoArg a)::_, rest') =>
156                          if (SS.isEmpty subs)                          if (SS.isEmpty subs)
157                            then (Opt(a()), rest')                            then (Opt(a()), rest')
158                            else (Opt(a()), ("-"^(SS.string subs))::rest')                            else (Opt(a()), ("-"^(SS.string subs))::rest')
159                      | ((ReqArg(f,d))::_, []) =>                      | ((ReqArg(f,d))::_, []) =>
160                          if (SS.isEmpty subs)                          if (SS.isEmpty subs)
161                            then (errReq(d, optStr); (NonOpt optStr, []))                            then (errReq(d, optStr); (NonOpt, []))
162                            else (Opt(f (SS.string subs)), [])                            else (Opt(f (SS.string subs)), [])
163                      | ((ReqArg(f,_))::_, rest' as (r::rs)) =>                      | ((ReqArg(f,_))::_, rest' as (r::rs)) =>
164                          if (SS.isEmpty subs)                          if (SS.isEmpty subs)
# Line 169  Line 168 
168                          if (SS.isEmpty subs)                          if (SS.isEmpty subs)
169                            then (Opt(f NONE), rest')                            then (Opt(f NONE), rest')
170                            else (Opt(f (SOME(SS.string subs))), rest')                            else (Opt(f (SOME(SS.string subs))), rest')
171                      | ([], rest') =>                      | ([], rest') => (errUnrec optStr; (NonOpt, rest'))
                         if (SS.isEmpty subs)  
                           then (errUnrec optStr; (NonOpt optStr, rest'))  
                           else (  
                             errUnrec optStr;  
                             (NonOpt optStr, ("-" ^ SS.string subs)::rest'))  
172                    (* end case *)                    (* end case *)
173                  end                  end
174          (* take a look at the next command line argument and decide what to            fun get ([], opts, nonOpts) = (List.rev opts, List.rev nonOpts)
175           * do with it              | get ("--"::rest, opts, nonOpts) = let
176           *)                  val nonOpts = List.revAppend(nonOpts, rest)
177            fun getNext ([], _) = raise Fail "getNext: impossible"                  in
178              | getNext ("--" :: rest, _) = (EndOfOpts, rest)                    case argOrder
179              | getNext (x::rest, optDescr) =  let                     of ReturnInOrder f => (List.revAppend(opts, List.map f nonOpts), [])
180                  val x' = SS.all x                      | _ => (List.rev opts, nonOpts)
181                  in                    (* end case *)
182                    if (SS.isPrefix "--" x')                  end
183                      then longOpt (SS.triml 2 x', rest, optDescr)              | get (arg::rest, opts, nonOpts) = let
184                    else if (SS.isPrefix "-" x')                  val arg' = SS.full arg
185                      then shortOpt (SS.sub(x',1), SS.triml 2 x', rest, optDescr)                  fun addOpt (Opt opt, rest) = get(rest, opt::opts, nonOpts)
186                    else (NonOpt x,rest)                    | addOpt (NonOpt, rest) = get(rest, opts, arg::nonOpts)
187                  end                  in
188            fun get [] = ([], [])                    if (SS.isPrefix "--" arg')
189              | get args = let                      then addOpt(longOpt (SS.triml 2 arg', rest))
190                  val (opt, rest) = getNext (args, options)                    else if (SS.isPrefix "-" arg')
191                  val (os, xs) = get rest                      then addOpt(shortOpt (SS.sub(arg', 1), SS.triml 2 arg', rest))
192                  fun procNextOpt (Opt o', _) = (o'::os, xs)                    else (case argOrder
193                    | procNextOpt (NonOpt x, RequireOrder) = ([],x::rest)                       of RequireOrder => (List.rev opts, List.revAppend(nonOpts, arg::rest))
194                    | procNextOpt (NonOpt x, Permute) = (os,x::xs)                        | Permute => get(rest, opts, arg::nonOpts)
195                    | procNextOpt (NonOpt x, ReturnInOrder f) = ((f x)::os,xs)                        | ReturnInOrder f => get(rest, f arg :: opts, nonOpts)
196                    | procNextOpt (EndOfOpts, RequireOrder) = ([],rest)                      (* end case *))
                   | procNextOpt (EndOfOpts, Permute) = ([],rest)  
                   | procNextOpt (EndOfOpts, ReturnInOrder f) = (map f rest,[])  
                 in  
                   procNextOpt(opt, argOrder)  
197                  end                  end
198            in            in
199              get              fn args => get(args, [], [])
200            end (* getOpt *)            end (* getOpt *)
201    
202    end    end

Legend:
Removed from v.1771  
changed lines
  Added in v.1772

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0