Shells in OCaml
Improve exit code handling
This introduces a `'a Exit.t` type for handling exit codes during the
execution of a series of commands. This is useful because unlike a
`Result.t` a non-zero exit code does not always mean _unrecoverable
error_.
+184
-60
+1
-1
src/bin/dune
+1
-1
src/bin/dune
+9
-5
src/bin/main.ml
+9
-5
src/bin/main.ml
···
1
1
(* A shell... one day *)
2
-
open Merry.Import
3
2
module C = Merry.Eval.Make (Merry_posix.State) (Merry_posix.Exec)
4
3
module I = Merry.Interactive.Make (Merry_posix.State) (Merry_posix.Exec)
5
4
6
5
let sh ~command ~dump ~file env =
7
6
let executor = Merry_posix.Exec.{ mgr = env#process_mgr } in
7
+
let interactive = Option.is_none file && Option.is_none command in
8
8
let ctx =
9
9
C.
10
10
{
11
+
interactive;
11
12
state =
12
13
Merry_posix.State.make
13
14
~home:(Sys.getenv "HOME" ^ "/")
14
-
(Fpath.v (Eunix.cwd ()));
15
+
(Fpath.v (Merry.Eunix.cwd ()));
15
16
executor;
16
17
fs = env#fs;
17
18
options = Merry.Eval.Options.default;
18
19
}
19
20
in
20
21
match (file, command) with
21
-
| None, None -> I.run ctx
22
+
| None, None -> I.run (Merry.Exit.zero ctx)
22
23
| _ ->
23
24
let ast =
24
25
match (file, command) with
···
28
29
in
29
30
if dump then Merry.Ast.Dump.pp Fmt.stdout ast
30
31
else
31
-
let _ctx, _ast = C.run ctx ast in
32
+
let _ctx, _ast = C.run (Merry.Exit.zero ctx) ast in
32
33
()
33
34
34
35
open Cmdliner
···
73
74
sh ~command ~dump ~file env
74
75
75
76
let main () = Eio_posix.run @@ fun env -> Cmd.eval (cmd env)
76
-
let () = if !Sys.interactive then () else exit (main ())
77
+
78
+
let () =
79
+
Fmt_tty.setup_std_outputs ();
80
+
if !Sys.interactive then () else exit (main ())
+27
src/lib/eunix.ml
+27
src/lib/eunix.ml
···
1
+
let cwd () = Eio_unix.run_in_systhread ~label:"cwd" @@ fun () -> Unix.getcwd ()
2
+
3
+
let chdir p =
4
+
try
5
+
let dir =
6
+
Eio_unix.run_in_systhread ~label:"chdir" @@ fun () -> Unix.chdir p
7
+
in
8
+
Exit.zero dir
9
+
with Unix.Unix_error (Unix.ENOENT, _, _) ->
10
+
Exit.nonzero_msg () "no such file or directory: %s" p
11
+
12
+
let env () =
13
+
Eio_unix.run_in_systhread ~label:"env" @@ fun () ->
14
+
Unix.environment ()
15
+
|> Array.map (Astring.String.cut ~sep:"=")
16
+
|> Array.to_list |> List.filter_map Fun.id
17
+
18
+
let find_env k = env () |> List.assoc_opt k
19
+
20
+
let put_env ~key ~value =
21
+
Eio_unix.run_in_systhread ~label:"put_env" @@ fun () -> Unix.putenv key value
22
+
23
+
let get_user_and_host () =
24
+
Eio_unix.run_in_systhread ~label:"get_user_and_host" @@ fun () ->
25
+
let name = Unix.getlogin () in
26
+
let host = Unix.gethostname () in
27
+
Fmt.str "%s@%s" name host
+51
-39
src/lib/eval.ml
+51
-39
src/lib/eval.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
-----------------------------------------------------------------*)
5
5
open Import
6
+
open Exit.Syntax
6
7
7
8
module Options = struct
8
9
type t = { noclobber : bool }
···
34
35
end
35
36
36
37
type ctx = {
38
+
interactive : bool;
37
39
state : S.t;
38
40
executor : E.t;
39
41
fs : Eio.Fs.dir_ty Eio.Path.t;
···
177
179
let handle_built_in (ctx : ctx) = function
178
180
| Built_ins.Cd { path } ->
179
181
let cwd = S.cwd ctx.state in
180
-
let new_cwd =
182
+
let+ state =
181
183
match path with
182
184
| Some p ->
183
185
let fp = Fpath.append cwd (Fpath.v p) in
184
-
Eunix.chdir p;
185
-
fp
186
-
| None -> Fpath.v ""
186
+
Exit.map' (Eunix.chdir p)
187
+
~zero:(fun () -> S.set_cwd ctx.state fp)
188
+
~nonzero:(fun () -> ctx.state)
189
+
| None -> (
190
+
match Eunix.find_env "HOME" with
191
+
| None -> Exit.nonzero_msg ctx.state "HOME not set"
192
+
| Some p -> Exit.zero (S.set_cwd ctx.state @@ Fpath.v p))
187
193
in
188
-
let state = S.set_cwd ctx.state new_cwd in
189
-
({ ctx with state }, Some 0)
194
+
{ ctx with state }
190
195
| Pwd ->
191
196
Fmt.pr "%s\n%!" (Eunix.cwd ());
192
-
(ctx, Some 0)
197
+
Exit.zero ctx
193
198
194
199
let cwd_of_ctx ctx = S.cwd ctx.state |> Fpath.to_string |> ( / ) ctx.fs
195
200
196
201
let execute_commands initial_ctx local_switch p =
197
-
let rec loop ctx (status_of_previous, stdout_of_previous) :
198
-
Ast.command list -> ctx * int option = function
202
+
let rec loop ctx
203
+
((status_of_previous, stdout_of_previous) :
204
+
ctx Exit.t * Eio_unix.source_ty Eio_unix.source option) :
205
+
Ast.command list -> ctx Exit.t = function
199
206
| Ast.SimpleCommand (Prefixed _) :: next ->
200
207
loop ctx (status_of_previous, stdout_of_previous) next
201
208
| Ast.SimpleCommand (Named (executable, None)) :: rest -> (
···
209
216
in
210
217
match stdout_of_previous with
211
218
| None ->
212
-
( ctx,
219
+
let+ () =
213
220
E.exec ctx.executor ?stdout:some_write ~cwd:(cwd_of_ctx ctx)
214
221
(List.map Ast.word_component_to_string executable)
215
-
|> Option.some )
222
+
in
223
+
ctx
216
224
| Some stdout ->
217
225
let res =
218
226
E.exec ctx.executor ~stdin:stdout ?stdout:some_write
219
227
~cwd:(cwd_of_ctx ctx)
220
228
(List.map Ast.word_component_to_string executable)
229
+
>|= fun () -> ctx
221
230
in
222
231
Option.iter Eio.Flow.close some_write;
223
-
loop ctx (Some res, some_read) rest))
232
+
loop ctx (res, some_read) rest))
224
233
| Ast.SimpleCommand (Named (executable, Some suffix)) :: rest -> (
225
234
let args =
226
235
List.filter_map
···
255
264
E.exec ~fds:redirect ctx.executor ?stdout:some_write
256
265
~cwd:(cwd_of_ctx ctx)
257
266
(List.map Ast.word_component_to_string executable @ args)
258
-
|> Option.some
267
+
>|= fun () -> ctx
259
268
in
260
269
Option.iter Eio.Flow.close some_write;
261
270
loop ctx (res, some_read) rest
···
264
273
E.exec ~fds:redirect ctx.executor ~stdin:stdout
265
274
~cwd:(cwd_of_ctx ctx) ?stdout:some_write
266
275
(List.map Ast.word_component_to_string executable @ args)
267
-
|> Option.some
276
+
>|= fun () -> ctx
268
277
in
269
278
Option.iter Eio.Flow.close some_write;
270
279
loop ctx (res, some_read) rest))
271
280
| v :: _ ->
272
281
Fmt.epr "TODO: %a" Yojson.Safe.pp (Ast.command_to_yojson v);
273
282
failwith "Err"
274
-
| [] -> (ctx, status_of_previous)
283
+
| [] -> status_of_previous
275
284
in
276
-
loop initial_ctx (None, None) p
285
+
loop initial_ctx (Exit.zero initial_ctx, None) p
277
286
278
287
let handle_single_pipeline ~sw ctx c =
279
288
let pipeline = function
280
289
| Ast.Pipeline p -> (Fun.id, p)
281
-
| Ast.Pipeline_Bang p ->
282
-
( (fun (ctx, v) ->
283
-
(ctx, Option.map (fun i -> if Int.equal i 0 then -1 else 0) v)),
284
-
p )
290
+
| Ast.Pipeline_Bang p -> (Exit.not, p)
285
291
in
286
292
287
293
let rec fold :
288
-
Ast.and_or * (ctx * int option) ->
289
-
Ast.pipeline Ast.and_or_list ->
290
-
ctx * int option =
291
-
fun (sep, (ctx, exit_so_far)) pipe ->
294
+
Ast.and_or * ctx Exit.t -> Ast.pipeline Ast.and_or_list -> ctx Exit.t =
295
+
fun (sep, exit_so_far) pipe ->
292
296
match (sep, pipe) with
293
297
| And, Nlist.Singleton (p, _) -> (
294
298
match exit_so_far with
295
-
| Some 0 ->
299
+
| Exit.Zero ctx ->
296
300
let f, p = pipeline p in
297
301
f @@ execute_commands ctx sw p
298
-
| v -> (ctx, v))
302
+
| v -> v)
299
303
| Or, Nlist.Singleton (p, _) -> (
300
304
match exit_so_far with
301
-
| Some 0 -> (ctx, Some 0)
305
+
| Exit.Zero _ as ctx -> ctx
302
306
| _ ->
303
307
let f, p = pipeline p in
304
308
f @@ execute_commands ctx sw p)
···
310
314
fold (next_sep, f (execute_commands ctx sw p)) rest
311
315
| And, Nlist.Cons ((p, next_sep), rest) -> (
312
316
match exit_so_far with
313
-
| Some 0 ->
317
+
| Exit.Zero ctx ->
314
318
let f, p = pipeline p in
315
319
fold (next_sep, f (execute_commands ctx sw p)) rest
316
-
| (None | Some _) as v -> (ctx, v))
320
+
| Exit.Nonzero _ as v -> v)
317
321
| Or, Nlist.Cons ((p, next_sep), rest) -> (
318
322
match exit_so_far with
319
-
| Some 0 -> fold (next_sep, (ctx, exit_so_far)) rest
320
-
| None | Some _ ->
323
+
| Exit.Zero _ as exit_so_far -> fold (next_sep, exit_so_far) rest
324
+
| Exit.Nonzero _ ->
321
325
let f, p = pipeline p in
322
326
fold (next_sep, f (execute_commands ctx sw p)) rest)
323
327
in
324
-
fold (Noand_or, (ctx, None)) c
328
+
fold (Noand_or, Exit.zero ctx) c
325
329
326
330
let exec initial_ctx (ast : Ast.complete_command) =
327
331
let command, _ = ast in
328
-
let rec loop : Eio.Switch.t -> ctx -> Ast.clist -> ctx * int option =
332
+
let rec loop : Eio.Switch.t -> ctx -> Ast.clist -> ctx Exit.t =
329
333
fun sw ctx -> function
330
334
| Nlist.Singleton (c, _) -> handle_single_pipeline ~sw ctx c
331
335
| Nlist.Cons ((c, (Semicolon | Nosep)), cs) -> (
332
336
match handle_single_pipeline ~sw ctx c with
333
-
| ctx, Some 0 -> loop sw ctx cs
337
+
| Exit.Zero ctx -> loop sw ctx cs
334
338
| v -> v)
335
339
| _ -> Fmt.failwith "Background tasks not implemented yet!"
336
340
in
···
351
355
let ctx, cs =
352
356
List.fold_left
353
357
(fun (ctx, cs) command ->
354
-
let (ctx, exit_code), ast =
355
-
expand ctx command ||> redirect ||> execute
356
-
in
357
-
Option.iter (function 0 -> () | n -> exit n) exit_code;
358
-
(ctx, ast :: cs))
358
+
let ctx = Exit.value ctx in
359
+
let exit, ast = expand ctx command ||> redirect ||> execute in
360
+
match exit with
361
+
| Exit.Nonzero { exit_code; message; should_exit; _ } -> (
362
+
Option.iter (Fmt.epr "%s\n%!") message;
363
+
match
364
+
( should_exit.interactive,
365
+
should_exit.non_interactive,
366
+
ctx.interactive )
367
+
with
368
+
| `Yes, _, true | _, `Yes, false -> Stdlib.exit exit_code
369
+
| _ -> (exit, ast :: cs))
370
+
| Exit.Zero _ as ctx -> (ctx, ast :: cs))
359
371
(ctx, []) ast
360
372
in
361
373
(ctx, List.rev cs)
+59
src/lib/exit.ml
+59
src/lib/exit.ml
···
1
+
(* The shell exit applicative? This is very like the result monad,
2
+
except modelled around a shell's exit status codes *)
3
+
4
+
type should_exit = {
5
+
interactive : [ `Yes | `No ];
6
+
non_interactive : [ `Yes | `No ];
7
+
}
8
+
9
+
let default_should_exit = { interactive = `No; non_interactive = `Yes }
10
+
11
+
type 'a t =
12
+
| Zero of 'a
13
+
| Nonzero of {
14
+
value : 'a;
15
+
exit_code : int;
16
+
message : string option;
17
+
should_exit : should_exit;
18
+
}
19
+
20
+
let value = function Zero v -> v | Nonzero { value; _ } -> value
21
+
22
+
let not = function
23
+
| Zero value ->
24
+
Nonzero
25
+
{
26
+
value;
27
+
exit_code = 1;
28
+
message = None;
29
+
should_exit = default_should_exit;
30
+
}
31
+
| Nonzero { value; _ } -> Zero value
32
+
33
+
let zero v = Zero v
34
+
35
+
let nonzero ?message ?(should_exit = default_should_exit) value exit_code =
36
+
Nonzero { value; exit_code; message; should_exit }
37
+
38
+
let nonzero_msg ?(exit_code = 1) ?(should_exit = default_should_exit) value fmt
39
+
=
40
+
Fmt.kstr
41
+
(fun message ->
42
+
Nonzero { value; exit_code; message = Some message; should_exit })
43
+
fmt
44
+
45
+
let map ~f = function
46
+
| Zero v -> Zero (f v)
47
+
| Nonzero ({ value; _ } as v) -> Nonzero { v with value = f value }
48
+
49
+
let map' ~zero ~nonzero = function
50
+
| Zero v -> Zero (zero v)
51
+
| Nonzero v -> Nonzero { v with value = nonzero v.value }
52
+
53
+
let is_nonzero = function Zero _ -> false | Nonzero _ -> true
54
+
let is_zero = function Zero _ -> true | Nonzero _ -> false
55
+
56
+
module Syntax = struct
57
+
let ( >|= ) x f = map ~f x
58
+
let ( let+ ) = ( >|= )
59
+
end
-8
src/lib/import.ml
-8
src/lib/import.ml
···
52
52
end
53
53
54
54
let yojson_pp = Yojson.Safe.pretty_print ~std:true
55
-
56
-
module Eunix = struct
57
-
let cwd () =
58
-
Eio_unix.run_in_systhread ~label:"cwd" @@ fun () -> Unix.getcwd ()
59
-
60
-
let chdir p =
61
-
Eio_unix.run_in_systhread ~label:"chdir" @@ fun () -> Unix.chdir p
62
-
end
+29
-4
src/lib/interactive.ml
+29
-4
src/lib/interactive.ml
···
1
+
let () = Fmt.set_style_renderer Format.str_formatter `Ansi_tty
2
+
1
3
module Make (S : Types.State) (E : Types.Exec) = struct
2
4
module Eval = Eval.Make (S) (E)
3
5
4
-
let default_prompt s =
5
-
Fmt.str "%s > %!" (Fpath.normalize @@ S.cwd s |> Fpath.to_string)
6
+
let pp_colored c pp fmt v = Fmt.pf fmt "%a" (Fmt.styled (`Fg c) pp) v
7
+
8
+
let subst_tilde path =
9
+
match Eunix.find_env "HOME" with
10
+
| None -> path
11
+
| Some home -> (
12
+
match Fpath.rem_prefix (Fpath.v home) path with
13
+
| Some rel -> Fpath.(v "~" // rel)
14
+
| None -> path)
15
+
16
+
let default_prompt (ctx : Eval.ctx Exit.t) =
17
+
let state =
18
+
match ctx with
19
+
| Exit.Zero ctx | Exit.Nonzero { value = ctx; _ } -> ctx.state
20
+
in
21
+
let pp_status ppf = function
22
+
| Exit.Zero _ -> ()
23
+
| Exit.Nonzero { exit_code; _ } ->
24
+
Fmt.pf ppf "[%a] " (pp_colored `Red Fmt.int) exit_code
25
+
in
26
+
Fmt.pf Format.str_formatter "%a%a:%s > %!" pp_status ctx
27
+
Fmt.(pp_colored `Yellow string)
28
+
(Eunix.get_user_and_host ())
29
+
(Fpath.normalize @@ S.cwd state |> subst_tilde |> Fpath.to_string);
30
+
Format.flush_str_formatter ()
6
31
7
32
let with_stdin_in_raw_mode fn =
8
33
let saved_tio = Unix.tcgetattr Unix.stdin in
···
40
65
fn
41
66
42
67
let run ?(prompt = default_prompt) initial_ctx =
43
-
let rec loop (ctx : Eval.ctx) =
44
-
let p = prompt ctx.state in
68
+
let rec loop (ctx : Eval.ctx Exit.t) =
69
+
let p = prompt ctx in
45
70
match LNoise.linenoise p with
46
71
| None -> loop ctx
47
72
| Some c ->
+2
src/lib/merry.ml
+2
src/lib/merry.ml
+2
src/lib/merry.mli
+2
src/lib/merry.mli
+3
-2
src/lib/posix/merry_posix.ml
+3
-2
src/lib/posix/merry_posix.ml
···
10
10
Eio.Switch.run @@ fun sw ->
11
11
Exec.run ~sw ~fds ~cwd ?stdin ?stdout ?stderr t args |> Eio.Process.await
12
12
|> function
13
-
| `Exited n -> n
14
-
| `Signaled n -> n
13
+
| `Exited 0 -> Merry.Exit.zero ()
14
+
| `Exited n -> Merry.Exit.nonzero () n
15
+
| `Signaled n -> Merry.Exit.nonzero () n
15
16
end