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
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
module Param = struct
let rec translate : type a. a Ast.Param.t -> a Climate.Arg_parser.conv = function
| Conv { docv; of_string; to_string } ->
let print fmt a = Format.pp_print_string fmt (to_string a) in
{ Climate.Arg_parser.parse = of_string
; print
; default_value_name = docv |> Option.value ~default:"VAL"
; completion = None
}
| String -> Climate.Arg_parser.string
| Int -> Climate.Arg_parser.int
| Float -> Climate.Arg_parser.float
| Bool -> Climate.Arg_parser.bool
| File -> Climate.Arg_parser.file
| Enum { docv; choices = hd :: tl; to_string } ->
let choices = hd :: tl in
let str x =
match List.find_opt (fun (_, y) -> y == x) choices with
| Some (a, _) -> a
| None -> to_string x
in
let eq a b = a == b || String.equal (str a) (str b) in
Climate.Arg_parser.enum ?default_value_name:docv choices ~eq
| Comma_separated t ->
let { Climate.Arg_parser.parse; print; default_value_name; completion = _ } =
translate t
in
let parse str =
let ok, msgs =
str
|> String.split_on_char ','
|> List.partition_map (fun arg ->
match parse arg with
| Ok x -> Left x
| Error (`Msg e) -> Right e)
in
match msgs with
| [] -> Ok ok
| _ :: _ -> Error (`Msg (String.concat ", " msgs))
in
let print fmt = function
| [] -> ()
| [ e ] -> print fmt e
| hd :: (_ :: _ as tl) ->
Format.fprintf fmt "%a," print hd;
tl |> List.iter (fun i -> Format.fprintf fmt ",%a" print i)
in
{ Climate.Arg_parser.parse; print; default_value_name; completion = None }
;;
end
module Arg = struct
let fmt_doc ~doc = doc
let make_doc : type a. doc:string -> param:a Ast.Param.t -> string =
fun ~doc ~param ->
match (param : _ Ast.Param.t) with
| Conv _ | String | Int | Float | Bool | File
| Enum { docv = _; choices = _; to_string = _ }
| Comma_separated _ -> fmt_doc ~doc
;;
let rec translate : type a. a Ast.Arg.t -> a Climate.Arg_parser.t = function
| Return x -> Climate.Arg_parser.const x
| Map { x; f } -> Climate.Arg_parser.map (translate x) ~f
| Both (a, b) -> Climate.Arg_parser.both (translate a) (translate b)
| Apply { f; x } -> Climate.Arg_parser.apply (translate f) (translate x)
| Flag { names = hd :: tl; doc } ->
let doc = fmt_doc ~doc in
Climate.Arg_parser.flag ~doc (hd :: tl)
| Flag_count { names = hd :: tl; doc } ->
let doc = fmt_doc ~doc in
Climate.Arg_parser.flag_count ~doc (hd :: tl)
| Named { names = hd :: tl; param; docv; doc } ->
let doc = make_doc ~doc ~param in
Climate.Arg_parser.named_req
~doc
?value_name:docv
(hd :: tl)
(param |> Param.translate)
| Named_multi { names = hd :: tl; param; docv; doc } ->
let doc = make_doc ~doc ~param in
Climate.Arg_parser.named_multi
~doc
?value_name:docv
(hd :: tl)
(param |> Param.translate)
| Named_opt { names = hd :: tl; param; docv; doc } ->
let doc = make_doc ~doc ~param in
Climate.Arg_parser.named_opt
~doc
?value_name:docv
(hd :: tl)
(param |> Param.translate)
| Named_with_default { names = hd :: tl; param; default; docv; doc } ->
let doc = make_doc ~doc ~param in
Climate.Arg_parser.named_with_default
~doc
?value_name:docv
(hd :: tl)
(param |> Param.translate)
~default
| Pos { pos; param; docv; doc } ->
let doc = make_doc ~doc ~param in
Climate.Arg_parser.pos_req ~doc ?value_name:docv pos (param |> Param.translate)
| Pos_opt { pos; param; docv; doc } ->
let doc = make_doc ~doc ~param in
Climate.Arg_parser.pos_opt ~doc ?value_name:docv pos (param |> Param.translate)
| Pos_with_default { pos; param; default; docv; doc } ->
let doc = make_doc ~doc ~param in
Climate.Arg_parser.pos_with_default
~doc
?value_name:docv
pos
(param |> Param.translate)
~default
| Pos_all { param; docv; doc } ->
let doc = make_doc ~doc ~param in
Climate.Arg_parser.pos_all ~doc ?value_name:docv (param |> Param.translate)
;;
end
module Command = struct
let doc ~summary ~readme =
match readme with
| None -> summary
| Some readme -> summary ^ "\n" ^ readme ()
;;
let rec to_command : type a. a Ast.Command.t -> a Climate.Command.t =
fun command ->
match command with
| Make { arg; summary; readme } ->
Climate.Command.singleton ~doc:(doc ~summary ~readme) (arg |> Arg.translate)
| Group { default; summary; readme; subcommands } ->
let cmds = subcommands |> List.map (fun (name, arg) -> to_subcommand arg ~name) in
Climate.Command.group
?default_arg_parser:(default |> Option.map Arg.translate)
~doc:(doc ~summary ~readme)
cmds
and to_subcommand
: type a. a Ast.Command.t -> name:string -> a Climate.Command.subcommand
=
fun command ~name -> Climate.Command.subcommand name (to_command command)
;;
end
module To_ast = Cmdlang.Command.Private.To_ast
let param p = p |> To_ast.param |> Param.translate
let arg a = a |> To_ast.arg |> Arg.translate
let command a = a |> To_ast.command |> Command.to_command
module Private = struct end