bright-ml/cli.sml at master · elpinal/bright-ml · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
open Std

functor CLI (X : sig
  val args : string list
end) : sig
  type error

  datatype flag_
    = None
    | Parse
    | Typecheck

  datatype flag
    = Std of flag_
    | NoStd of flag_

  datatype t
    = Normal of string * flag
    | Help
    | Version
    | Error of error

  val v : t

  val show_error : error -> string
  val usage : string
end = struct
  datatype flag_
    = None
    | Parse
    | Typecheck

  fun show_flag None      = ""
    | show_flag Parse     = "-parse"
    | show_flag Typecheck = "-typecheck"

  datatype flag
    = Std of flag_
    | NoStd of flag_

  fun no_std (Std f) = NoStd f
    | no_std x       = x

  datatype error
    = UnrecognizedFlag of string
    | TooManyArguments of int
    | FlagConflict of flag_ * flag_

  fun show_error (UnrecognizedFlag s) = "unrecognized flag: " ^ s
    | show_error (TooManyArguments n) = "too many arguments (" ^ Int.toString n ^ ")"
    | show_error (FlagConflict(x, y)) = "flag conflict: " ^ show_flag x ^ " vs " ^ show_flag y

  exception FlagConflict_ of flag_ * flag_

  fun None <> flag = flag
    | flag <> None           = flag
    | Parse <> Parse         = Parse
    | Typecheck <> Typecheck = Typecheck
    | x <> y                 = raise FlagConflict_(x, y)

  val op<> = fn
      (Std x, y)   => Std $ x <> y
    | (NoStd x, y) => NoStd $ x <> y

  datatype t
    = Normal of string * flag
    | Help
    | Version
    | Error of error

  val usage = String.concat $ map (fn s => s ^ "\n")
  [ "Bright ML"
  , "  bright-ml [options] filename"
  , ""
  , "options:"
  , "  -h"
  , "  -help"
  , "  --help"
  , "  -v"
  , "  -version"
  , "  -parse"
  , "  -typecheck"
  , "  -no-std"
  ]

  fun f args =
    case args of
         [] => Help
       | x :: xs =>
           case x of
                "-h" => Help
              | "-help" => Help
              | "--help" => Help
              | "-v" => Version
              | "-version" => Version
              | "-parse" =>
                  let in
                    case f xs of
                         Normal(s, flag) => Normal(s, flag <> Parse)
                       | v               => v
                  end
              | "-typecheck" =>
                  let in
                    case f xs of
                         Normal(s, flag) => Normal(s, flag <> Typecheck)
                       | v               => v
                  end
              | "-no-std" =>
                  let in
                    case f xs of
                         Normal(s, flag) => Normal(s, no_std flag)
                       | v               => v
                  end
              | _ =>
                  case String.explode x of
                       #"-" :: flag => Error $ UnrecognizedFlag $ String.implode flag
                     | _            =>
                         case xs of
                              [] => Normal(x, Std None)
                            | _  => Error $ TooManyArguments $ List.length args

  val v = f X.args
    handle FlagConflict_(x, y) => Error $ FlagConflict(x, y)
end