lib/mlton/basic/popt.sml

   1 (* Copyright (C) 2009,2017 Matthew Fluet.
   2  * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 structure Popt: POPT =
  11 struct
  12
  13 datatype t =
  14    Bool of bool -> unit
  15  | Digit of int -> unit
  16  | Int of int -> unit
  17  | Mem of int -> unit
  18  | None of unit -> unit
  19  | Real of real -> unit
  20  | SpaceString of string -> unit
  21  | SpaceString2 of string * string -> unit
  22  | String of string -> unit
  23  | Word of word -> unit
  24
  25 local
  26    fun make b (r: bool ref): t = None (fn () => r := b)
  27 in
  28    val trueRef = make true
  29    val falseRef = make false
  30 end
  31
  32 fun boolRef (r: bool ref): t = Bool (fn b => r := b)
  33
  34 fun intRef (r: int ref): t = Int (fn n => r := n)
  35
  36 fun stringRef (r: string ref): t = String (fn s => r := s)
  37
  38 fun wordRef (r: word ref): t = Word (fn w => r := w)
  39
  40 val trace = ("trace", SpaceString (fn s =>
  41                                    let
  42                                       open Trace.Immediate
  43                                       val _ = debug := Out Out.error
  44                                    in case s of
  45                                       "*" => always ()
  46                                     | _ => (flagged ()
  47                                             ; on (String.split (s, #",")))
  48                                    end))
  49
  50 fun memString (s: string): int option =
  51    let
  52       val n = String.size s
  53       fun loop (i, ac) =
  54          if i >= n
  55             then SOME ac
  56          else
  57             let val c = String.sub (s, i)
  58                fun done n = SOME (n * ac)
  59             in case c of
  60                #"m" => done 1048576
  61              | #"k" => done 1024
  62              | _ =>
  63                   case Char.digitToInt c of
  64                      NONE => NONE
  65                    | SOME c => loop (i + 1, ac * 10 + c)
  66             end
  67    in loop (0, 0)
  68    end
  69
  70 (* Parse the command line opts and return any remaining args. *)
  71 fun parse {switches: string list,
  72            opts: (string * t) list}: string list Result.t =
  73    let
  74       exception Error of string
  75       val rec loop =
  76          fn [] => []
  77           | switch :: switches =>
  78                let
  79                   fun error s = raise (Error s)
  80                in
  81                   case String.sub (switch, 0) of
  82                      #"-" =>
  83                      let val switch = String.dropPrefix (switch, 1)
  84                      in case List.peek (opts, fn (switch', _) =>
  85                                         switch = switch') of
  86                         NONE =>
  87                            let
  88                               (* Handle the switches where there is no space
  89                                * separating the argument.
  90                                *)
  91                               val rec loop' =
  92                                  fn [] => error (concat ["unknown switch: -",
  93                                                          switch])
  94                                   | (switch', arg) :: opts =>
  95                                        let
  96                                           fun doit f =
  97                                              if String.hasPrefix
  98                                                 (switch, {prefix = switch'})
  99                                                 then f (String.dropPrefix
 100                                                         (switch, String.size switch'))
 101                                              else loop' opts
 102                                        in case arg of
 103                                           Digit f =>
 104                                              doit (fn s =>
 105                                                    let
 106                                                       val error =
 107                                                          fn () =>
 108                                                          error (concat ["invalid digit ", s, " used with -", switch])
 109                                                    in
 110                                                       if size s = 1
 111                                                          then (case Char.digitToInt
 112                                                                   (String.sub (s, 0)) of
 113                                                                   NONE => error ()
 114                                                                 | SOME i => f i)
 115                                                       else error ()
 116                                                    end)
 117                                         | String f => doit f
 118                                         | _ => loop' opts
 119                                        end
 120                            in loop' opts
 121                               ; loop switches
 122                            end
 123                       | SOME (_, arg) =>
 124                            let
 125                               fun next (f: 'a -> unit, get, msg) =
 126                                  case switches of
 127                                     [] =>
 128                                        error (concat ["-", switch, " requires an argument"])
 129                                   | switch' :: switches =>
 130                                        case get switch' of
 131                                           NONE => error (concat ["-", switch, " requires ", msg])
 132                                         | SOME n => (f n; loop switches)
 133                            in
 134                               case arg of
 135                                  Bool f => next (f, Bool.fromString, "a boolean")
 136                                | Digit _ =>
 137                                     error (concat ["-", switch, " requires a digit"])
 138                                | Int f => next (f, Int.fromString, "an integer")
 139                                | Mem f => next (f, memString, "a memory amount")
 140                                | None f => (f (); loop switches)
 141                                | Real f => next (f, Real.fromString, "a real")
 142                                | SpaceString f => next (f, SOME, "")
 143                                | SpaceString2 f =>
 144                                     (case switches of
 145                                         s1 :: s2 :: switches =>
 146                                            (f (s1, s2); loop switches)
 147                                       | _ => error (concat ["-", switch, " requires two arguments"]))
 148                                | String f => (f ""; loop switches)
 149                                | Word f => next (f, Word.fromString, "a word")
 150                            end
 151                      end
 152                    | _ => switch :: switches
 153                end
 154    in
 155       Result.Yes (loop switches) handle Error s => Result.No s
 156    end
 157
 158 datatype optionStyle = Normal | Expert
 159
 160 fun makeUsage {mainUsage, makeOptions, showExpert} =
 161    let
 162       val usageRef: (string -> unit) option ref = ref NONE
 163       fun usage (s: string): unit = valOf (!usageRef) s
 164       fun options () = makeOptions {usage = usage}
 165       val _ =
 166          usageRef :=
 167          SOME
 168          (fn s =>
 169           let
 170              val out = Out.error
 171              fun message s = Out.outputl (out, s)
 172              val opts =
 173                 List.fold
 174                 (rev (options ()), [],
 175                  fn ({arg, desc, opt = _, name, style}, rest) =>
 176                  if style = Normal orelse showExpert ()
 177                     then [concat ["    -", name, arg, " "], desc] :: rest
 178                  else rest)
 179              val table =
 180                 let
 181                    open Justify
 182                 in
 183                    table {columnHeads = NONE,
 184                           justs = [Left, Left],
 185                           rows = opts}
 186                 end
 187           in
 188              message s
 189              ; message (concat ["usage: ", mainUsage])
 190              ; List.foreach (table, fn ss =>
 191                              message (String.removeTrailing
 192                                       (concat ss, Char.isSpace)))
 193              ; let open OS.Process
 194                in if MLton.isMLton
 195                      then exit failure
 196                   else Error.bug "Popt.makeUsage"
 197                end
 198           end)
 199       val parse =
 200          fn switches =>
 201          parse {opts = List.map (options (), fn {name, opt, ...} => (name, opt)),
 202                 switches = switches}
 203    in
 204       {parse = parse,
 205        usage = usage}
 206    end
 207
 208 end