1(* ========================================================================= *)
2(* PROCESSING COMMAND LINE OPTIONS                                           *)
3(* Copyright (c) 2003 Joe Hurd, distributed under the BSD License            *)
4(* ========================================================================= *)
5
6structure Options :> Options =
7struct
8
9open Useful;
10
11(* ------------------------------------------------------------------------- *)
12(* One command line option: names, arguments, description and a processor    *)
13(* ------------------------------------------------------------------------- *)
14
15type proc = string * string list -> unit;
16
17type ('a,'x) mkProc = ('x -> proc) -> ('a -> 'x) -> proc;
18
19type opt = {switches : string list, arguments : string list,
20            description : string, processor : proc};
21
22(* ------------------------------------------------------------------------- *)
23(* Option processors may raise an OptionExit exception                       *)
24(* ------------------------------------------------------------------------- *)
25
26type optionExit = {message : string option, usage : bool, success : bool};
27
28exception OptionExit of optionExit;
29
30(* ------------------------------------------------------------------------- *)
31(* Wrappers for option processors                                            *)
32(* ------------------------------------------------------------------------- *)
33
34fun beginOpt f p (s : string, l : string list) : unit = f (p s) (s,l);
35
36fun endOpt () (_ : string, [] : string list) = ()
37  | endOpt _ (_, _ :: _) = raise Bug "endOpt";
38
39fun stringOpt _ _ (_ : string, []) = raise Bug "stringOpt"
40  | stringOpt f p (s, (h : string) :: t) : unit = f (p h) (s,t);
41
42local
43  fun range NONE NONE = "Z"
44    | range (SOME i) NONE = "{n IN Z | " ^ Int.toString i ^ " <= n}"
45    | range NONE (SOME j) = "{n IN Z | n <= " ^ Int.toString j ^ "}"
46    | range (SOME i) (SOME j) =
47    "{n IN Z | " ^ Int.toString i ^ " <= n <= " ^ Int.toString j ^ "}";
48  fun oLeq (SOME x) (SOME y) = x <= y | oLeq _ _ = true;
49  fun argToInt arg omin omax x =
50    (case Int.fromString x of
51       SOME i =>
52       if oLeq omin (SOME i) andalso oLeq (SOME i) omax then i else
53         raise OptionExit
54           {success = false, usage = false, message =
55            SOME (arg ^ " option needs an integer argument in the range "
56                  ^ range omin omax ^ " (not " ^ x ^ ")")}
57     | NONE =>
58       raise OptionExit
59         {success = false, usage = false, message =
60          SOME (arg ^ " option needs an integer argument (not \"" ^ x ^ "\")")})
61    handle Overflow =>
62       raise OptionExit
63         {success = false, usage = false, message =
64          SOME (arg ^ " option suffered integer overflow on argument " ^ x)};
65in
66  fun intOpt _ _ _ (_,[]) = raise Bug "intOpt"
67    | intOpt (omin,omax) f p (s:string, h :: (t : string list)) : unit =
68      f (p (argToInt s omin omax h)) (s,t);
69end;
70
71local
72  fun range NONE NONE = "R"
73    | range (SOME i) NONE = "{n IN R | " ^ Real.toString i ^ " <= n}"
74    | range NONE (SOME j) = "{n IN R | n <= " ^ Real.toString j ^ "}"
75    | range (SOME i) (SOME j) =
76    "{n IN R | " ^ Real.toString i ^ " <= n <= " ^ Real.toString j ^ "}";
77  fun oLeq (SOME (x:real)) (SOME y) = x <= y | oLeq _ _ = true;
78  fun argToReal arg omin omax x =
79    (case Real.fromString x of
80       SOME i =>
81       if oLeq omin (SOME i) andalso oLeq (SOME i) omax then i else
82         raise OptionExit
83           {success = false, usage = false, message =
84            SOME (arg ^ " option needs an real argument in the range "
85                  ^ range omin omax ^ " (not " ^ x ^ ")")}
86     | NONE =>
87       raise OptionExit
88         {success = false, usage = false, message =
89          SOME (arg ^ " option needs an real argument (not \"" ^ x ^ "\")")})
90in
91  fun realOpt _ _ _ (_,[]) = raise Bug "realOpt"
92    | realOpt (omin,omax) f p (s:string, h :: (t : string list)) : unit =
93      f (p (argToReal s omin omax h)) (s,t);
94end;
95
96fun enumOpt _ _ _ (_,[]) = raise Bug "enumOpt"
97  | enumOpt (choices : string list) f p (s : string, h :: t) : unit =
98    if mem h choices then f (p h) (s,t) else
99      raise OptionExit
100        {success = false, usage = false,
101         message = SOME ("follow parameter " ^ s ^ " with one of {" ^
102                         join "," choices ^ "}, not \"" ^ h ^ "\"")};
103
104fun optionOpt _ _ _ (_,[]) = raise Bug "optionOpt"
105  | optionOpt (x : string, p) f q (s : string, l as h :: t) : unit =
106    if h = x then f (q NONE) (s,t) else p f (q o SOME) (s,l);
107
108(* ------------------------------------------------------------------------- *)
109(* Basic options useful for all programs                                     *)
110(* ------------------------------------------------------------------------- *)
111
112val basicOptions : opt list =
113  [{switches = ["--"], arguments = [],
114    description = "no more options",
115    processor = fn _ => raise Fail "basicOptions: --"},
116   {switches = ["-?","-h","--help"], arguments = [],
117    description = "display option information and exit",
118    processor = fn _ => raise OptionExit
119    {message = SOME "displaying option information",
120     usage = true, success = true}},
121   {switches = ["-v", "--version"], arguments = [],
122    description = "display version information",
123    processor = fn _ => raise Fail "basicOptions: -v, --version"}];
124
125(* ------------------------------------------------------------------------- *)
126(* All the command line options of a program                                 *)
127(* ------------------------------------------------------------------------- *)
128
129type allOptions =
130     {name : string, version : string, header : string,
131      footer : string, options : opt list};
132
133(* ------------------------------------------------------------------------- *)
134(* Usage information                                                         *)
135(* ------------------------------------------------------------------------- *)
136
137fun versionInformation ({version, ...} : allOptions) = version;
138
139fun usageInformation ({name,version,header,footer,options} : allOptions) =
140  let
141    fun listOpts {switches = n, arguments = r, description = s,
142                  processor = _} =
143        let
144          fun indent (s, "" :: l) = indent (s ^ "  ", l) | indent x = x
145          val (res,n) = indent ("  ",n)
146          val res = res ^ join ", " n
147          val res = List.foldl (fn (x,y) => y ^ " " ^ x) res r
148        in
149          [res ^ " ...", " " ^ s]
150        end
151
152    val alignment =
153        [{leftAlign = true, padChar = #"."},
154         {leftAlign = true, padChar = #" "}]
155
156    val table = alignTable alignment (List.map listOpts options)
157  in
158    header ^ join "\n" table ^ "\n" ^ footer
159  end;
160
161(* ------------------------------------------------------------------------- *)
162(* Exit the program gracefully                                               *)
163(* ------------------------------------------------------------------------- *)
164
165fun exit (allopts : allOptions) (optexit : optionExit) =
166  let
167    val {name, options, ...} = allopts
168    val {message, usage, success} = optexit
169    fun err s = TextIO.output (TextIO.stdErr, s)
170  in
171    case message of NONE => () | SOME m => err (name ^ ": " ^ m ^ "\n");
172    if usage then err (usageInformation allopts) else ();
173    OS.Process.exit (if success then OS.Process.success else OS.Process.failure)
174  end;
175
176fun succeed allopts =
177    exit allopts {message = NONE, usage = false, success = true};
178
179fun fail allopts mesg =
180    exit allopts {message = SOME mesg, usage = false, success = false};
181
182fun usage allopts mesg =
183    exit allopts {message = SOME mesg, usage = true, success = false};
184
185fun version allopts =
186    (TextIO.print (versionInformation allopts);
187     exit allopts {message = NONE, usage = false, success = true});
188
189(* ------------------------------------------------------------------------- *)
190(* Process the command line options passed to the program                    *)
191(* ------------------------------------------------------------------------- *)
192
193fun processOptions (allopts : allOptions) =
194  let
195    fun findOption x =
196      case List.find (fn {switches = n, ...} => mem x n) (#options allopts) of
197        NONE => raise OptionExit
198                        {message = SOME ("unknown switch \"" ^ x ^ "\""),
199                         usage = true, success = false}
200      | SOME {arguments = r, processor = f, ...} => (r,f)
201
202    fun getArgs x r xs =
203      let
204        fun f 1 = "a following argument"
205          | f m = Int.toString m ^ " following arguments"
206        val m = length r
207        val () =
208          if m <= length xs then () else
209            raise OptionExit
210              {usage = false, success = false, message = SOME
211               (x ^ " option needs " ^ f m ^ ": " ^ join " " r)}
212      in
213        divide xs m
214      end
215
216    fun process [] = ([], [])
217      | process ("--" :: xs) = ([("--",[])], xs)
218      | process ("-v" :: _) = version allopts
219      | process ("--version" :: _) = version allopts
220      | process (x :: xs) =
221      if x = "" orelse x = "-" orelse hd (String.explode x) <> #"-" then
222        ([], x :: xs)
223      else
224        let
225          val (r,f) = findOption x
226          val (ys,xs) = getArgs x r xs
227          val () = f (x,ys)
228
229          val (xys,xs) = process xs
230        in
231          ((x,ys) :: xys, xs)
232        end
233  in
234    fn l =>
235       let
236         val (a,b) = process l
237
238         val a = List.foldl (fn ((x,xs),ys) => x :: xs @ ys) [] (List.rev a)
239       in
240         (a,b)
241       end
242       handle OptionExit x => exit allopts x
243  end;
244
245end
246