Shells in OCaml
1let () = Fmt.set_style_renderer Format.str_formatter `Ansi_tty
2
3module Make (S : Types.State) (E : Types.Exec) = struct
4 module Eval = Eval.Make (S) (E)
5
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 >\n%!" 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 ()
31
32 let _with_stdin_in_raw_mode fn =
33 let saved_tio = Unix.tcgetattr Unix.stdin in
34 let tio =
35 {
36 saved_tio with
37 (* input modes *)
38 c_ignpar = true;
39 c_istrip = false;
40 c_inlcr = false;
41 c_igncr = false;
42 c_ixon = false;
43 (* c_ixany = false; *)
44 (* c_iuclc = false; *)
45 c_ixoff = false;
46 (* output modes *)
47 c_opost = true;
48 (* control modes *)
49 c_isig = false;
50 c_icanon = false;
51 c_echo = false;
52 c_echoe = false;
53 c_echok = false;
54 c_echonl = false;
55 (* c_iexten = false; *)
56
57 (* special characters *)
58 c_vmin = 1;
59 c_vtime = 0;
60 }
61 in
62 Unix.tcsetattr Unix.stdin TCSADRAIN tio;
63 Fun.protect
64 ~finally:(fun () -> Unix.tcsetattr Unix.stdin TCSADRAIN saved_tio)
65 fn
66
67 let run ?(prompt = default_prompt) initial_ctx =
68 let rec loop (ctx : Eval.ctx Exit.t) =
69 let p = prompt ctx in
70 Fmt.pr "%s\r%!" p;
71 match LNoise.linenoise "" with
72 | None ->
73 Fmt.pr "exit\n%!";
74 exit 0
75 | Some c ->
76 let ast = Ast.of_string c in
77 let ctx', _ast = Eval.run ctx ast in
78 (* TODO: Make better History abstraction *)
79 let _ : (unit, string) result = LNoise.history_add c in
80 loop ctx'
81 | exception Sys.Break ->
82 let c = Exit.value ctx in
83 loop (Exit.nonzero c 130)
84 in
85 loop initial_ctx
86end