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