patrick.sirref.org
Shells in OCaml
1let () = Fmt.set_style_renderer Format.str_formatter `Ansi_tty
2
3module Make (S : Types.State) (E : Types.Exec) (H : Types.History) = 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; _ } -> Eval.state ctx
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 let fs = Exit.value ctx |> Eval.fs in
27 Fmt.pf Format.str_formatter "%a%a:%s >\n%!" pp_status ctx
28 Fmt.(pp_colored `Yellow string)
29 (Eunix.get_user_and_host fs)
30 (Fpath.normalize @@ S.cwd state |> subst_tilde |> Fpath.to_string);
31 Format.flush_str_formatter ()
32
33 let resolve_programs name =
34 if not (String.contains name '/') then begin
35 Eunix.find_env "PATH"
36 |> Option.value ~default:"/bin:/usr/bin"
37 |> String.split_on_char ':'
38 |> List.concat_map (fun dir ->
39 let files = try Sys.readdir dir |> Array.to_list with _ -> [] in
40 List.filter (fun f -> String.starts_with ~prefix:name f) files)
41 end
42 else if Sys.file_exists name then [ name ]
43 else []
44
45 let complete path =
46 let rest, last_arg =
47 String.split_on_char ' ' path |> List.rev |> function
48 | [] -> ([], `None)
49 | [ prog ] -> ([], `Prog prog)
50 | x :: rest -> (List.rev rest, `Path x)
51 in
52 let completions from_path basename =
53 match (Unix.stat from_path).st_kind with
54 | S_DIR ->
55 let entries = Sys.readdir from_path |> Array.to_list in
56 List.filter_map
57 (fun e ->
58 match basename with
59 | None -> Some e
60 | Some prefix ->
61 if String.starts_with ~prefix e then Some e else None)
62 entries
63 |> List.map (fun e -> Filename.concat from_path e)
64 |> List.map (fun p -> String.concat " " (rest @ [ p ]))
65 | S_REG -> [ String.concat " " (rest @ [ path ]) ]
66 | _ -> []
67 | exception Unix.Unix_error (Unix.ENOTDIR, _, _) -> []
68 | exception Unix.Unix_error (Unix.ENOENT, _, _) -> []
69 in
70 match last_arg with
71 | `None -> []
72 | `Prog prog -> resolve_programs prog
73 | `Path path -> (
74 match Unix.(stat path).st_kind with
75 | exception Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) ->
76 let dirname = Filename.dirname path in
77 let basename =
78 match Filename.basename path with "." | "" -> None | p -> Some p
79 in
80 completions dirname basename
81 | S_DIR -> completions path None
82 | _ -> [])
83
84 let run ?(prompt = default_prompt) initial_ctx =
85 Sys.set_signal Sys.sigttou Sys.Signal_ignore;
86 Sys.set_signal Sys.sigttin Sys.Signal_ignore;
87 Sys.set_signal Sys.sigtstp Sys.Signal_ignore;
88 Sys.set_signal Sys.sigint Sys.Signal_ignore;
89 let xdg = Xdge.create (Eval.fs (Exit.value initial_ctx)) "merry" in
90 let history = Eio.Path.(Xdge.data_dir xdg / ".merry_history") in
91 let initial_history = try H.load history with _ -> H.empty in
92 let h = ref initial_history in
93 let add_history c =
94 let c = String.trim c in
95 h := H.add (H.make_entry c) !h
96 in
97 let rec loop (ctx : Eval.ctx Exit.t) =
98 Option.iter (Fmt.epr "%s%!")
99 (S.lookup (Exit.value ctx |> Eval.state) ~param:"PS1");
100 let p = prompt ctx in
101 Fmt.pr "%s\r%!" p;
102 let hint command =
103 if String.length command < 2 then None
104 else
105 match H.history ~command !h |> H.commands with
106 | [] -> None
107 | x :: _ -> (
108 match Astring.String.cut ~sep:command x with
109 | Some ("", rest) -> Some (rest, `Fg (`Hi `Magenta))
110 | _ -> None)
111 in
112 match
113 Bruit.bruit ~hint
114 ~history:(fun command -> H.history ~command !h |> H.commands)
115 ~complete "% "
116 with
117 | String None ->
118 Fmt.pr "exit\n%!";
119 exit 0
120 | String (Some c) ->
121 let ast = Ast.of_string (String.trim c) in
122 Fmt.pr "\n%!";
123 let ctx', _ast = Eval.run ctx ast in
124 add_history c;
125 H.save !h history;
126 loop ctx'
127 | Ctrl_c ->
128 let c = Exit.value ctx in
129 Eunix.Signals.(raise Interrupt);
130 if Eval.sigint_set c then loop (Exit.zero c)
131 else begin
132 Fmt.pr "\n%!";
133 loop (Exit.nonzero c 130)
134 end
135 in
136 loop initial_ctx
137end