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