1(* SPDX-License-Identifier: SMLNJ *)
2(* SPDX-FileCopyrightText: 1998 Bell Labs, Lucent Technologies *)
3
4(* getopt.sml
5 *
6 * COPYRIGHT (c) 1998 Bell Labs, Lucent Technologies.
7 *
8 * See comments in GetOpt.sml
9 *
10 *)
11
12
13structure GetOpt :> GetOpt =
14  struct
15
16    datatype 'a arg_order
17      = RequireOrder
18      | Permute
19      | ReturnInOrder of string -> 'a
20
21    datatype 'a arg_descr
22      = NoArg of unit -> 'a
23      | ReqArg of (string -> 'a) * string
24      | OptArg of (string option -> 'a) * string
25
26    type 'a opt_descr = {
27        short : string,
28        long : string list,
29        desc : 'a arg_descr,
30        help : string
31      }
32
33    datatype 'a opt_kind
34      = Opt of 'a
35      | NonOpt
36
37    structure SS = Substring
38    structure S = String
39
40
41    (* helper functions *)
42    fun sepBy (sep, []) = ""
43      | sepBy (sep, x::xs) =
44          concat (x::foldr (fn (elem,l) => sep::elem::l) [] xs)
45
46    val breakeq = SS.splitl (fn #"=" => false | _ => true)
47
48
49    (* formatting of options *)
50
51    fun fmtShort (NoArg _) so = concat ["-", str so]
52      | fmtShort (ReqArg (_,ad)) so = concat ["-", str so," ",ad]
53      | fmtShort (OptArg (_,ad)) so = concat ["-", str so,"[",ad,"]"]
54
55    fun fmtLong (NoArg _) lo = concat ["--",lo]
56      | fmtLong (ReqArg (_,ad)) lo = concat ["--",lo,"=",ad]
57      | fmtLong (OptArg (_,ad)) lo = concat ["--",lo,"[=",ad,"]"]
58
59    fun fmtOpt {short=sos, long=los, desc=ad, help=descr} = (
60          String.concatWith ", " (map (fmtShort ad) (S.explode sos)),
61          String.concatWith ", " (map (fmtLong ad) los),
62          descr)
63
64  (* Usage information *)
65    fun usageInfo {header, options} = let
66          fun unlines l = sepBy ("\n", l)
67          val fmtOptions = List.map fmtOpt options
68          val (ms1, ms2) = foldl
69                (fn ((e1,e2,_), (m1,m2)) => (
70                    Int.max (size e1, m1),
71                    Int.max (size e2, m2)
72                  )) (0,0) fmtOptions
73          val indent = StringCvt.padLeft #" " (ms1 + ms2 + 6)
74          val pad = StringCvt.padRight #" "
75          fun doEntry ((e1, e2, e3), l) = (
76                case String.fields (fn #"\n" => true | _ => false) e3
77                 of [] => concat["  ", pad ms1 e1, "  ", pad ms2 e2] :: l
78                  | [e3] => concat["  ", pad ms1 e1, "  ", pad ms2 e2, "  ", e3] :: l
79                  | fst::rest =>
80                      concat["  ", pad ms1 e1, "  ", pad ms2 e2, "  ", fst]
81                        :: List.foldr (fn (s, l) => (indent "" ^ s) :: l) l rest
82                (* end case *))
83          val table = List.foldr doEntry [""] fmtOptions
84          in
85            String.concatWith "\n" (header::table)
86          end
87
88    (* entry point of the library
89     *)
90
91    fun getOpt {argOrder, options : 'a opt_descr list, errFn} = let
92       (* Some error handling functions *)
93          fun errAmbig optStr = errFn(usageInfo{
94                  header = concat[
95                      "option `", optStr, "' is ambiguous; could be one of:"
96                    ],
97                  options = options
98                })
99          fun errReq (d, optStr) = errFn(concat[
100                  "option `", optStr, "' requires an argument ", d
101                ])
102          fun errUnrec optStr = errFn(concat[
103                  "unrecognized option `", optStr, "'"
104                ])
105          fun errNoArg optStr = errFn(concat[
106                  "option `", optStr, "' does not allow an argument"
107                ])
108        (* handle long option
109         * this is messy because you cannot pattern-match on substrings
110         *)
111          fun longOpt (subs, rest) = let
112                val (opt, arg) = breakeq subs
113                val opt' = SS.string opt
114                val options = List.filter
115                      (fn {long,...} => List.exists (S.isPrefix opt') long)
116                        options
117                val optStr = "--"^opt'
118                fun long (_::(_::_), _, rest') = (
119                      errAmbig optStr; (NonOpt, rest'))
120                  | long ([NoArg a], x, rest') =
121                      if (SS.isEmpty x)
122                      then (Opt(a()),rest')
123                      else if (SS.isPrefix "=" x)
124                           then (errNoArg optStr; (NonOpt, rest'))
125                           else raise Fail "long: impossible"
126                  | long ([ReqArg(f,d)], x, []) =
127                      if (SS.isEmpty x)
128                      then (errReq(d, optStr); (NonOpt, []))
129                      else if (SS.isPrefix "=" x)
130                           then (Opt(f (SS.string (SS.triml 1 x))), [])
131                           else raise Fail "long: impossible"
132                  | long ([ReqArg(f,d)], x, rest' as (r::rs)) =
133                      if (SS.isEmpty x)
134                      then (Opt(f r), rs)
135                      else if (SS.isPrefix "=" x)
136                           then (Opt(f (SS.string (SS.triml 1 x))), rest')
137                           else raise Fail "long: impossible"
138                  | long ([OptArg(f,_)], x, rest') =
139                      if (SS.isEmpty x)
140                      then (Opt(f NONE), rest')
141                      else if (SS.isPrefix "=" x)
142                           then (Opt(f (SOME (SS.string (SS.triml 1 x)))), rest')
143                           else raise Fail "long: impossible"
144                  | long ([], _, rest') = (
145                      errUnrec optStr; (NonOpt, rest'))
146                in
147                  long (map #desc options, arg, rest)
148                end
149        (* handle short option.  x is the option character, subs is the
150         * rest of the option string, rest is the rest of the command-line
151         * options.
152         *)
153          fun shortOpt (x, subs, rest) = let
154                val options =
155                      List.filter (fn {short,...} => Char.contains short x) options
156                val ads = map #desc options
157                val optStr = "-"^(str x)
158                in
159                  case (ads, rest)
160                   of (_::_::_, rest1) => (errAmbig optStr; (NonOpt, rest1))
161                    | ((NoArg a)::_, rest') =>
162                        if (SS.isEmpty subs)
163                          then (Opt(a()), rest')
164                          else (Opt(a()), ("-"^(SS.string subs))::rest')
165                    | ((ReqArg(f,d))::_, []) =>
166                        if (SS.isEmpty subs)
167                          then (errReq(d, optStr); (NonOpt, []))
168                          else (Opt(f (SS.string subs)), [])
169                    | ((ReqArg(f,_))::_, rest' as (r::rs)) =>
170                        if (SS.isEmpty subs)
171                          then (Opt(f r), rs)
172                          else (Opt(f (SS.string subs)), rest')
173                    | ((OptArg(f,_))::_, rest') =>
174                        if (SS.isEmpty subs)
175                          then (Opt(f NONE), rest')
176                          else (Opt(f (SOME(SS.string subs))), rest')
177                    | ([], rest') => (errUnrec optStr; (NonOpt, rest'))
178                  (* end case *)
179                end
180          fun get ([], opts, nonOpts) = (List.rev opts, List.rev nonOpts)
181            | get ("--"::rest, opts, nonOpts) = let
182                val nonOpts = List.revAppend(nonOpts, rest)
183                in
184                  case argOrder
185                   of ReturnInOrder f => (List.revAppend(opts, List.map f nonOpts), [])
186                    | _ => (List.rev opts, nonOpts)
187                  (* end case *)
188                end
189            | get (arg::rest, opts, nonOpts) = let
190                val arg' = SS.full arg
191                fun addOpt (Opt opt, rest) = get(rest, opt::opts, nonOpts)
192                  | addOpt (NonOpt, rest) = get(rest, opts, arg::nonOpts)
193                in
194                  if (SS.isPrefix "--" arg')
195                  then addOpt(longOpt (SS.triml 2 arg', rest))
196                  else if (SS.isPrefix "-" arg') then
197                    if SS.size arg' = 1 then
198                      (errFn "Malformed option (-)"; get(rest, opts, nonOpts))
199                    else
200                      addOpt(shortOpt (SS.sub(arg', 1), SS.triml 2 arg', rest))
201                  else (case argOrder
202                     of RequireOrder => (List.rev opts, List.revAppend(nonOpts, arg::rest))
203                      | Permute => get(rest, opts, arg::nonOpts)
204                      | ReturnInOrder f => get(rest, f arg :: opts, nonOpts)
205                    (* end case *))
206                end
207          in
208            fn args => get(args, [], [])
209          end (* getOpt *)
210
211  end
212