Shells in OCaml
1(*-----------------------------------------------------------------
2 Copyright (c) 2025 The merry programmers. All rights reserved.
3 SPDX-License-Identifier: ISC
4 -----------------------------------------------------------------*)
5open Import
6open Exit.Syntax
7
8module Options = struct
9 type t = { noclobber : bool }
10
11 let default = { noclobber = false }
12
13 let with_options ?noclobber t =
14 { noclobber = Option.value ~default:t.noclobber noclobber }
15end
16
17(** An evaluator over the AST *)
18module Make (S : Types.State) (E : Types.Exec) = struct
19 (* What follows uses the POSIX definition of what a shell does ($ 2.1).
20
21 It starts from point (4), completing a series of expansions on the AST,
22 then redirection is setup, and finally functions/built-ins/commands are
23 executed. *)
24
25 class default_map =
26 object (_)
27 inherit Ast.map
28 method string (s : string) = s
29 method int (i : int) = i
30 method char c = c
31 method option f v = Option.map f v
32 method nlist__t f t = Nlist.map f t
33 method nslist__t f t = Nslist.map f t
34 method list f t = List.map f t
35 end
36
37 type ctx = {
38 interactive : bool;
39 state : S.t;
40 local_state : (string * string) list;
41 executor : E.t;
42 fs : Eio.Fs.dir_ty Eio.Path.t;
43 options : Options.t;
44 stdout : Eio_unix.sink_ty Eio.Flow.sink option;
45 }
46
47 let clear_local_state ctx = { ctx with local_state = [] }
48
49 class default_ctx_fold =
50 object (_)
51 inherit [ctx] Ast.fold
52 method int _ ctx = ctx
53 method string _ ctx = ctx
54 method char _ ctx = ctx
55 method option f v ctx = Option.fold ~none:ctx ~some:(fun i -> f i ctx) v
56 method nlist__t f v ctx = Nlist.fold_left (fun acc i -> f i acc) ctx v
57
58 method nslist__t f g v ctx =
59 Nslist.fold_left (fun acc a b -> f a acc |> g b) ctx v
60
61 method list f v ctx = List.fold_left (fun acc i -> f i acc) ctx v
62 end
63
64 let map_word_components f ast =
65 let o =
66 object (_)
67 inherit default_map
68 method! word_component cst = f cst
69 end
70 in
71 o#complete_command ast
72
73 let map_words ?(skip_for_clauses = true) f =
74 let o =
75 object (_)
76 inherit default_map as super
77 method! word cst = f cst
78
79 method! for_clause cst =
80 if skip_for_clauses then cst else super#for_clause cst
81 end
82 in
83 o
84
85 let rec tilde_expansion ctx = function
86 | [] -> []
87 | Ast.WordTildePrefix _ :: rest ->
88 Ast.WordName (S.expand ctx.state `Tilde) :: tilde_expansion ctx rest
89 | v :: rest -> v :: tilde_expansion ctx rest
90
91 let parameter_expansion' ctx =
92 let rec expand = function
93 | [] -> []
94 | Ast.WordVariable v :: rest -> (
95 match v with
96 | Ast.VariableAtom (s, NoAttribute) -> (
97 match S.lookup ctx.state ~param:s with
98 | None -> Ast.WordName "" :: expand rest
99 | Some cst -> cst @ expand rest)
100 | _ -> Fmt.failwith "No support for variable attributes yet!")
101 | Ast.WordDoubleQuoted cst :: rest ->
102 Ast.WordDoubleQuoted (expand cst) :: expand rest
103 | Ast.WordSingleQuoted cst :: rest ->
104 Ast.WordSingleQuoted (expand cst) :: expand rest
105 | v :: rest -> v :: expand rest
106 in
107 (ctx, expand)
108
109 let stdout_for_pipeline ~sw ctx = function
110 | [] -> (None, ctx.stdout)
111 | _ ->
112 let r, w = Eio_unix.pipe sw in
113 (Some r, Some (w :> Eio_unix.sink_ty Eio.Flow.sink))
114
115 let fd_of_int ?(close_unix = true) ~sw n =
116 Eio_unix.Fd.of_unix ~close_unix ~sw (Obj.magic n : Unix.file_descr)
117
118 let handle_one_redirection ~sw ctx = function
119 | Ast.IoRedirect_IoFile (n, (op, file)) -> (
120 match op with
121 | Io_op_less ->
122 (* Simple redirection for input *)
123 let r =
124 Eio.Path.open_in ~sw (ctx.fs / Ast.word_components_to_string file)
125 in
126 let fd = Eio_unix.Resource.fd_opt r |> Option.get in
127 Some (Types.Redirect (n, fd, `Blocking))
128 | Io_op_lessand -> (
129 match file with
130 | [ WordLiteral "-" ] ->
131 if n = 0 then Some (Types.Close Eio_unix.Fd.stdin)
132 else
133 let fd = fd_of_int ~sw n in
134 Some (Types.Close fd)
135 | [ WordLiteral m ] when Option.is_some (int_of_string_opt m) ->
136 let m = int_of_string m in
137 Some
138 (Types.Redirect
139 (n, fd_of_int ~close_unix:false ~sw m, `Blocking))
140 | _ -> None)
141 | (Io_op_great | Io_op_dgreat) as v ->
142 (* Simple file creation *)
143 let append = v = Io_op_dgreat in
144 let w =
145 Eio.Path.open_out ~sw ~append ~create:(`If_missing 0o644)
146 (ctx.fs / Ast.word_components_to_string file)
147 in
148 let fd = Eio_unix.Resource.fd_opt w |> Option.get in
149 Some (Types.Redirect (n, fd, `Blocking))
150 | Io_op_greatand -> (
151 match file with
152 | [ WordLiteral "-" ] ->
153 if n = 0 then Some (Types.Close Eio_unix.Fd.stdin)
154 else
155 let fd = fd_of_int ~sw n in
156 Some (Types.Close fd)
157 | [ WordLiteral m ] when Option.is_some (int_of_string_opt m) ->
158 let m = int_of_string m in
159 Some
160 (Types.Redirect
161 (n, fd_of_int ~close_unix:false ~sw m, `Blocking))
162 | _ -> None)
163 | Io_op_clobber -> Fmt.failwith ">| not supported yet."
164 | Io_op_lessgreat -> Fmt.failwith "<> not support yet.")
165 | Ast.IoRedirect_IoHere _ ->
166 Fmt.failwith "HERE documents not yet implemented!"
167
168 let handle_built_in (ctx : ctx) = function
169 | Built_ins.Cd { path } ->
170 let cwd = S.cwd ctx.state in
171 let+ state =
172 match path with
173 | Some p ->
174 let fp = Fpath.append cwd (Fpath.v p) in
175 Exit.map' (Eunix.chdir p)
176 ~zero:(fun () -> S.set_cwd ctx.state fp)
177 ~nonzero:(fun () -> ctx.state)
178 | None -> (
179 match Eunix.find_env "HOME" with
180 | None -> Exit.nonzero_msg ctx.state "HOME not set"
181 | Some p -> Exit.zero (S.set_cwd ctx.state @@ Fpath.v p))
182 in
183 { ctx with state }
184 | Pwd ->
185 Fmt.pr "%s\n%!" (Eunix.cwd ());
186 Exit.zero ctx
187 | Exit n ->
188 let should_exit =
189 { Exit.default_should_exit with interactive = `Yes }
190 in
191 Exit.nonzero_msg ~should_exit ctx ~exit_code:n "exit"
192
193 let cwd_of_ctx ctx = S.cwd ctx.state |> Fpath.to_string |> ( / ) ctx.fs
194
195 let needs_glob_expansion : Ast.word_component -> bool = function
196 | WordGlobAll | WordGlobAny -> true
197 | _ -> false
198
199 let apply_pair (a, b) f = f a b
200 let ( ||> ) = apply_pair
201
202 let get_env ?(extra = []) () =
203 let env = Eunix.env () in
204 List.fold_left (fun acc (k, _) -> List.remove_assoc k acc) env extra
205 |> List.append extra
206
207 let rec execute_commands initial_ctx local_switch p =
208 let rec loop (exit_ctx : ctx Exit.t)
209 (stdout_of_previous : Eio_unix.source_ty Eio_unix.source option) :
210 Ast.command list -> ctx Exit.t =
211 fun c ->
212 let ctx = Exit.value exit_ctx in
213 match c with
214 | Ast.SimpleCommand (Prefixed (prefix, None, _suffix)) :: rest ->
215 let ctx = collect_assignments ctx prefix in
216 loop (Exit.zero ctx) stdout_of_previous rest
217 | Ast.SimpleCommand (Prefixed (prefix, Some executable, suffix)) :: rest
218 ->
219 let ctx = collect_assignments ~update:false ctx prefix in
220 loop (Exit.zero ctx) stdout_of_previous
221 (Ast.SimpleCommand (Named (executable, suffix)) :: rest)
222 | Ast.SimpleCommand (Named (executable, None)) :: rest -> (
223 let ctx, executable = expand_cst ctx executable in
224 match
225 Built_ins.of_args
226 [ handle_word_components_to_string ctx executable ]
227 with
228 | Some bi -> handle_built_in ctx bi
229 | None -> (
230 let some_read, some_write =
231 stdout_for_pipeline ctx ~sw:local_switch rest
232 in
233 match stdout_of_previous with
234 | None ->
235 let executable =
236 handle_word_components_to_string ctx executable
237 in
238 let res =
239 E.exec ctx.executor ?stdout:some_write ~cwd:(cwd_of_ctx ctx)
240 ~env:(get_env ~extra:ctx.local_state ())
241 [ executable ]
242 >|= fun () -> clear_local_state ctx
243 in
244 Option.iter Eio.Flow.close some_write;
245 loop res some_read rest
246 | Some stdout ->
247 let executable =
248 handle_word_components_to_string ctx executable
249 in
250 let res =
251 E.exec ctx.executor ~stdin:stdout ?stdout:some_write
252 ~env:(get_env ~extra:ctx.local_state ())
253 ~cwd:(cwd_of_ctx ctx) [ executable ]
254 >|= fun () -> clear_local_state ctx
255 in
256 Option.iter Eio.Flow.close some_write;
257 loop res some_read rest))
258 | Ast.SimpleCommand (Named (executable, Some suffix)) :: rest -> (
259 let ctx, executable = expand_cst ctx executable in
260 let ctx, suffix = expand_redirects (ctx, []) suffix in
261 let args = args ctx suffix in
262 match
263 Built_ins.of_args
264 (handle_word_components_to_string ctx executable :: args)
265 with
266 | Some bi -> handle_built_in ctx bi
267 | None -> (
268 let redirect =
269 List.fold_left
270 (fun acc -> function
271 | Ast.Suffix_word _ -> acc
272 | Ast.Suffix_redirect rdr ->
273 handle_one_redirection ~sw:local_switch ctx rdr :: acc)
274 [] suffix
275 |> List.rev |> List.filter_map Fun.id
276 in
277 let some_read, some_write =
278 stdout_for_pipeline ~sw:local_switch ctx rest
279 in
280 match stdout_of_previous with
281 | None ->
282 let res =
283 E.exec ~fds:redirect ctx.executor ?stdout:some_write
284 ~cwd:(cwd_of_ctx ctx)
285 ~env:(get_env ~extra:ctx.local_state ())
286 (handle_word_components_to_string ctx executable :: args)
287 >|= fun () -> clear_local_state ctx
288 in
289 Option.iter Eio.Flow.close some_write;
290 loop res some_read rest
291 | Some stdout ->
292 let res =
293 E.exec ~fds:redirect ctx.executor ~stdin:stdout
294 ~cwd:(cwd_of_ctx ctx) ?stdout:some_write
295 ~env:(get_env ~extra:ctx.local_state ())
296 (handle_word_components_to_string ctx executable :: args)
297 >|= fun () -> clear_local_state ctx
298 in
299 Option.iter Eio.Flow.close some_write;
300 loop res some_read rest))
301 | CompoundCommand (c, rdrs) :: _rest ->
302 let _rdrs =
303 List.map (handle_one_redirection ~sw:local_switch ctx) rdrs
304 in
305 let ctx = handle_compound_command ctx c in
306 ctx
307 | v :: _ ->
308 Fmt.epr "TODO: %a" Yojson.Safe.pp (Ast.command_to_yojson v);
309 failwith "Err"
310 | [] -> exit_ctx
311 in
312 loop (Exit.zero initial_ctx) None p
313
314 and expand_cst (ctx : ctx) cst =
315 let cst = tilde_expansion ctx cst in
316 let _, o = parameter_expansion' ctx in
317 (ctx, o cst)
318
319 and expand_redirects ((ctx, acc) : ctx * Ast.cmd_suffix_item list)
320 (c : Ast.cmd_suffix_item list) =
321 match c with
322 | [] -> (ctx, List.rev acc)
323 | Ast.Suffix_redirect (IoRedirect_IoFile (num, (op, file))) :: rest ->
324 let ctx, cst = expand_cst ctx file in
325 let cst = handle_subshell ctx cst in
326 let v = Ast.Suffix_redirect (IoRedirect_IoFile (num, (op, cst))) in
327 expand_redirects (ctx, v :: acc) rest
328 | (Ast.Suffix_redirect _ as v) :: rest ->
329 expand_redirects (ctx, v :: acc) rest
330 | s :: rest -> expand_redirects (ctx, s :: acc) rest
331
332 and handle_single_pipeline ~sw ctx c =
333 let pipeline = function
334 | Ast.Pipeline p -> (Fun.id, p)
335 | Ast.Pipeline_Bang p -> (Exit.not, p)
336 in
337
338 let rec fold :
339 Ast.and_or * ctx Exit.t -> Ast.pipeline Ast.and_or_list -> ctx Exit.t =
340 fun (sep, exit_so_far) pipe ->
341 match (sep, pipe) with
342 | And, Nlist.Singleton (p, _) -> (
343 match exit_so_far with
344 | Exit.Zero ctx ->
345 let f, p = pipeline p in
346 f @@ execute_commands ctx sw p
347 | v -> v)
348 | Or, Nlist.Singleton (p, _) -> (
349 match exit_so_far with
350 | Exit.Zero _ as ctx -> ctx
351 | _ ->
352 let f, p = pipeline p in
353 f @@ execute_commands ctx sw p)
354 | Noand_or, Nlist.Singleton (p, _) ->
355 let f, p = pipeline p in
356 f @@ execute_commands ctx sw p
357 | Noand_or, Nlist.Cons ((p, next_sep), rest) ->
358 let f, p = pipeline p in
359 fold (next_sep, f (execute_commands ctx sw p)) rest
360 | And, Nlist.Cons ((p, next_sep), rest) -> (
361 match exit_so_far with
362 | Exit.Zero ctx ->
363 let f, p = pipeline p in
364 fold (next_sep, f (execute_commands ctx sw p)) rest
365 | Exit.Nonzero _ as v -> v)
366 | Or, Nlist.Cons ((p, next_sep), rest) -> (
367 match exit_so_far with
368 | Exit.Zero _ as exit_so_far -> fold (next_sep, exit_so_far) rest
369 | Exit.Nonzero _ ->
370 let f, p = pipeline p in
371 fold (next_sep, f (execute_commands ctx sw p)) rest)
372 in
373 fold (Noand_or, Exit.zero ctx) c
374
375 and handle_for_clause ctx = function
376 | Ast.For_Name_DoGroup (_, (term, sep)) -> exec ctx (term, Some sep)
377 | Ast.For_Name_In_WordList_DoGroup (Name name, wdlist, (term, sep)) ->
378 let wdlist = Nlist.flatten @@ Nlist.map (word_glob_expand ctx) wdlist in
379 Nlist.fold_left
380 (fun _ word ->
381 let s = S.update ctx.state ~param:name [ Ast.WordLiteral word ] in
382 let ctx = { ctx with state = s } in
383 exec ctx (term, Some sep))
384 (Exit.zero ctx) wdlist
385
386 and handle_if_clause ctx = function
387 | Ast.If_then ((e1, sep1), (e2, sep2)) -> (
388 let ctx = exec ctx (e1, Some sep1) in
389 match ctx with
390 | Exit.Zero ctx -> exec ctx (e2, Some sep2)
391 | Exit.Nonzero { value = ctx; _ } -> Exit.zero ctx)
392 | Ast.If_then_else ((e1, sep1), (e2, sep2), else_part) -> (
393 let ctx = exec ctx (e1, Some sep1) in
394 match ctx with
395 | Exit.Zero ctx -> exec ctx (e2, Some sep2)
396 | Exit.Nonzero { value = ctx; _ } -> handle_else_part ctx else_part)
397
398 and handle_else_part ctx = function
399 | Ast.Else (c, sep) -> exec ctx (c, Some sep)
400 | Ast.Elif_then ((e1, sep1), (e2, sep2)) -> (
401 let ctx = exec ctx (e1, Some sep1) in
402 match ctx with
403 | Exit.Zero ctx -> exec ctx (e2, Some sep2)
404 | Exit.Nonzero { value = ctx; _ } -> Exit.zero ctx)
405 | Ast.Elif_then_else ((e1, sep1), (e2, sep2), else_part) -> (
406 let ctx = exec ctx (e1, Some sep1) in
407 match ctx with
408 | Exit.Zero ctx -> exec ctx (e2, Some sep2)
409 | Exit.Nonzero { value = ctx; _ } -> handle_else_part ctx else_part)
410
411 and handle_compound_command ctx = function
412 | Ast.ForClause fc -> handle_for_clause ctx fc
413 | Ast.IfClause if_ -> handle_if_clause ctx if_
414 | _ as c ->
415 Fmt.failwith "Compound command not supported: %a" yojson_pp
416 (Ast.compound_command_to_yojson c)
417
418 and needs_subshelling = function
419 | [] -> false
420 | Ast.WordSubshell _ :: _ -> true
421 | Ast.WordDoubleQuoted word :: rest ->
422 needs_subshelling word || needs_subshelling rest
423 | Ast.WordSingleQuoted word :: rest ->
424 needs_subshelling word || needs_subshelling rest
425 | _ -> false
426
427 and handle_subshell (ctx : ctx) wcs =
428 let exec_subshell ~sw ctx s =
429 let buf = Buffer.create 16 in
430 let stdout = Eio.Flow.buffer_sink buf in
431 let r, w = Eio_unix.pipe sw in
432 Eio.Fiber.fork ~sw (fun () -> Eio.Flow.copy r stdout);
433 let subshell_ctx = { ctx with stdout = Some w } in
434 let _ = run (Exit.zero subshell_ctx) s in
435 (ctx, Buffer.contents buf)
436 in
437 let rec run_subshells ~sw ran_subshell = function
438 | [] -> []
439 | Ast.WordSubshell s :: rest ->
440 let _ctx, std = exec_subshell ~sw ctx s in
441 ran_subshell := true;
442 Ast.WordName (String.trim std) :: run_subshells ~sw ran_subshell rest
443 | Ast.WordDoubleQuoted word :: rest ->
444 let subshell_q = ref false in
445 let res = run_subshells ~sw subshell_q word in
446 if !subshell_q then res @ run_subshells ~sw subshell_q rest
447 else Ast.WordDoubleQuoted res :: run_subshells ~sw subshell_q rest
448 | Ast.WordSingleQuoted word :: rest ->
449 let subshell_q = ref false in
450 let res = run_subshells ~sw subshell_q word in
451 if !subshell_q then res @ run_subshells ~sw subshell_q rest
452 else Ast.WordSingleQuoted res :: run_subshells ~sw subshell_q rest
453 | v :: rest -> v :: run_subshells ~sw ran_subshell rest
454 in
455 Eio.Switch.run @@ fun sw -> run_subshells ~sw (ref false) wcs
456
457 and handle_word_components_to_string (ctx : ctx) wcs : string =
458 if needs_subshelling wcs then begin
459 let wcs = handle_subshell ctx wcs in
460 Ast.word_components_to_string wcs
461 end
462 else Ast.word_components_to_string wcs
463
464 and glob_expand ctx wc =
465 handle_word_components_to_string ctx wc |> Globlon.glob |> Array.to_list
466
467 and word_glob_expand (ctx : ctx) wc =
468 if List.exists needs_glob_expansion wc then glob_expand ctx wc
469 else [ handle_word_components_to_string ctx wc ]
470
471 and collect_assignments ?(update = true) ctx =
472 List.fold_left
473 (fun ctx -> function
474 | Ast.Prefix_assignment (Name param, v) ->
475 (* Expand the values *)
476 let ctx, v = expand_cst ctx v in
477 let state =
478 if update then S.update ctx.state ~param v else ctx.state
479 in
480 {
481 ctx with
482 state;
483 local_state =
484 (param, Ast.word_components_to_string v) :: ctx.local_state;
485 }
486 | _ -> ctx)
487 ctx
488
489 and args ctx swc =
490 List.concat_map
491 (function
492 | Ast.Suffix_redirect _ -> []
493 | Suffix_word wc ->
494 let ctx, cst = expand_cst ctx wc in
495 word_glob_expand ctx cst)
496 swc
497
498 and exec initial_ctx (ast : Ast.complete_command) =
499 let command, _ = ast in
500 let rec loop : Eio.Switch.t -> ctx -> Ast.clist -> ctx Exit.t =
501 fun sw ctx -> function
502 | Nlist.Singleton (c, _) -> handle_single_pipeline ~sw ctx c
503 | Nlist.Cons ((c, (Semicolon | Nosep)), cs) -> (
504 match handle_single_pipeline ~sw ctx c with
505 | Exit.Zero ctx -> loop sw ctx cs
506 | v -> v)
507 | _ -> Fmt.failwith "Background tasks not implemented yet!"
508 in
509 Eio.Switch.run @@ fun sw -> loop sw initial_ctx command
510
511 and execute ctx ast = exec ctx ast
512
513 and run ctx ast =
514 let ctx, cs =
515 List.fold_left
516 (fun (ctx, cs) command ->
517 let ctx = Exit.value ctx in
518 let exit = execute ctx command in
519 match exit with
520 | Exit.Nonzero { exit_code; message; should_exit; _ } -> (
521 Option.iter (Fmt.epr "%s\n%!") message;
522 match
523 ( should_exit.interactive,
524 should_exit.non_interactive,
525 ctx.interactive )
526 with
527 | `Yes, _, true | _, `Yes, false -> Stdlib.exit exit_code
528 | _ -> (exit, ast :: cs))
529 | Exit.Zero _ as ctx -> (ctx, ast :: cs))
530 (ctx, []) ast
531 in
532 (ctx, List.rev cs)
533end