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 complete path =
33 let rest, last_arg =
34 String.split_on_char ' ' path |> List.rev |> function
35 | [] -> ([], None)
36 | x :: rest -> (List.rev rest, Some x)
37 in
38 let completions from_path basename =
39 match (Unix.stat from_path).st_kind with
40 | S_DIR ->
41 let entries = Sys.readdir from_path |> Array.to_list in
42 List.filter_map
43 (fun e ->
44 match basename with
45 | None -> Some e
46 | Some prefix ->
47 if String.starts_with ~prefix e then Some e else None)
48 entries
49 |> List.map (fun e -> Filename.concat from_path e)
50 |> List.map (fun p -> String.concat " " (rest @ [ p ]))
51 | S_REG -> [ String.concat " " (rest @ [ path ]) ]
52 | _ -> []
53 | exception Unix.Unix_error (Unix.ENOENT, _, _) -> []
54 in
55 match last_arg with
56 | None -> []
57 | Some path -> (
58 match Unix.(stat path).st_kind with
59 | exception Unix.Unix_error (Unix.ENOENT, _, _) ->
60 let dirname = Filename.dirname path in
61 let basename =
62 match Filename.basename path with "." | "" -> None | p -> Some p
63 in
64 completions dirname basename
65 | S_DIR -> completions path None
66 | _ -> [])
67
68 (* For now a very simple, prefixed based history *)
69
70 let h = ref []
71
72 let add_history c =
73 let c = String.trim c in
74 let new_h = List.filter (fun s -> not (String.equal c s)) !h in
75 h := c :: new_h
76
77 let history prefix =
78 if prefix <> "" then List.filter (fun s -> String.starts_with ~prefix s) !h
79 else !h
80
81 let run ?(prompt = default_prompt) initial_ctx =
82 Sys.set_signal Sys.sigttou Sys.Signal_ignore;
83 Sys.set_signal Sys.sigttin Sys.Signal_ignore;
84 Sys.set_signal Sys.sigtstp Sys.Signal_ignore;
85 let rec loop (ctx : Eval.ctx Exit.t) =
86 Option.iter (Fmt.epr "%s%!")
87 (S.lookup (Exit.value ctx).state ~param:"PS1"
88 |> Option.map Ast.word_components_to_string);
89 let p = prompt ctx in
90 Fmt.pr "%s\r%!" p;
91 match Bruit.bruit ~history ~complete "" with
92 | String None ->
93 Fmt.pr "exit\n%!";
94 exit 0
95 | String (Some c) ->
96 let ast = Ast.of_string (String.trim c) in
97 let ctx', _ast = Eval.run ctx ast in
98 add_history c;
99 loop ctx'
100 | Ctrl_c ->
101 let c = Exit.value ctx in
102 loop (Exit.nonzero c 130)
103 in
104 loop initial_ctx
105end