├── .gitignore ├── .merlin ├── CHANGES.md ├── LICENSE.md ├── README.md ├── TODO.md ├── _tags ├── opam ├── pkg ├── META └── pkg.ml ├── src ├── shell.ml ├── shell.mli ├── shell.mllib ├── shell_ast.ml ├── shell_ast.mli ├── shell_commands.ml ├── shell_commands.mli ├── shell_eval.ml ├── shell_eval.mli ├── shell_highlight.ml ├── shell_highlight.mli ├── shell_history.ml ├── shell_history.mli ├── shell_lexer.ml ├── shell_lexer.mli ├── shell_predictions.ml ├── shell_predictions.mli ├── shell_state.ml ├── shell_state.mli ├── shell_types.ml └── shell_types.mli └── unix ├── shell_unix.ml ├── shell_unix.mli └── shell_unix.mllib /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | B _build/** 2 | FLG -w +a-4-44-48 3 | 4 | S src 5 | PKG lwt sedlex uutf 6 | 7 | S unix 8 | PKG lwt.unix notty notty.unix notty.lwt 9 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## v0.1 (2016-09-12) 2 | 3 | * Initial version. 4 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Ciaran Lawlor 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. 4 | 5 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Shell (In development) 2 | 3 | Lets you create interactive shells in OCaml. 4 | 5 | ## Example 6 | 7 | ```ocaml 8 | open Shell.Commands 9 | 10 | let echo_cmd = 11 | let echo = Lwt_io.printl in 12 | let arg = Arg.pos ~predict:(fun _ -> ["Hello world"]) () in 13 | Command.(create "echo" echo $ arg) 14 | 15 | let commands = Map.empty |> Map.add echo_cmd 16 | 17 | let () = 18 | Lwt_main.run (Shell_unix.run commands) 19 | ``` 20 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | ### Parsing 2 | * Single dash works for long names and double dash works for short names. Also requires support in prediction. 3 | - Multiple short names joined together. 4 | - Using `=` to separate , using `--` to force pos arg, and gluing to short opts. 5 | 6 | ### Commands 7 | * Args may signal an error or might indicate that help / usage should be printed. 8 | * Add flexible pos args that get remaining values, use for write and echo. 9 | * Add help arg to commands somehow. 10 | * Print help / usage when required arg is omitted. Also when eval-ing and there is an unknown arg, instead of printing and error. Probably shouldn't print directly, should use UI somehow. Currently passing the print_error function to eval, which isn't great. 11 | - Check / handle when different opt args have the same name? Currently I think the earlier one will take the value of the later one as the mapping is based on strings, which is bad. 12 | 13 | ### Prediction 14 | * Showing possibilities with their doc, and allowing choice. Pressing tab after tab has already been pressed to do longest prefix should complete a full option. 15 | - Better escaping - only escape existing string parts to string. 16 | - Completing a short arg doesn't result in one dash. Short names should be joined on. 17 | 18 | ### History 19 | - Can currently modify history, could have actual history and modified history in state. 20 | - Need to not add if duplicate of last. 21 | - Limiting size. 22 | - Persisting the history to disk somewhere. 23 | - Using in prediction and navigating history by searching with partially typed command. 24 | 25 | ### Unix / Notty UI 26 | * When line wrapping, the cursor isn't displayed (as it's going off screen). 27 | * Could split input at pos, draw left, save cursor pos, draw right. 28 | * There's still a bug where if the last line isn't blank then it is overwritten. Need a way to get the column number. 29 | - Add new line characters if input isn't terminated. Test with consecutive newlines. 30 | - print_error needs to handle new lines, and remove other escape characters. Alternatively print "Error:" with Notty then print with something else. 31 | - Insert key and keyboard shortcuts. 32 | - Resizing doesn't cause a redraw. 33 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true : warn(+a-4-44-48), bin_annot, safe_string 2 | true : package(result) 3 | 4 | : include 5 | : package(lwt), package(sedlex), package(uutf) 6 | 7 | : include 8 | : package(lwt.unix), package(notty.unix), package(notty.lwt) 9 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | homepage: "https://github.com/ciaran16/shell" 3 | dev-repo: "https://github.com/ciaran16/shell.git" 4 | bug-reports: "https://github.com/ciaran16/shell/issues" 5 | author: "Ciaran Lawlor" 6 | maintainer: "Ciaran Lawlor" 7 | license: "ISC" 8 | 9 | build: [ 10 | "ocaml" "pkg/pkg.ml" "build" "--pinned" pinned 11 | ] 12 | 13 | depends: [ 14 | "ocamlbuild" {build} 15 | "ocamlfind" {build} 16 | "topkg" {build} 17 | "result" 18 | "lwt" 19 | "sedlex" 20 | "uutf" 21 | "notty" 22 | ] 23 | available: [ocaml-version >= "4.02.0"] 24 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | description = "shell" 2 | version = "0.1" 3 | requires = "lwt sedlex uutf" 4 | archive(byte) = "shell.cma" 5 | archive(native) = "shell.cmxa" 6 | plugin(byte) = "shell.cma" 7 | plugin(native) = "shell.cmxs" 8 | 9 | package "unix" ( 10 | description = "shell" 11 | version = "0.1" 12 | requires = "shell lwt lwt.unix notty notty.unix notty.lwt" 13 | archive(byte) = "shell_unix.cma" 14 | archive(native) = "shell_unix.cmxa" 15 | plugin(byte) = "shell_unix.cma" 16 | plugin(native) = "shell_unix.cmxs" 17 | ) 18 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | open Topkg 5 | 6 | let unix = Conf.with_pkg "unix" ~default:true 7 | 8 | let () = 9 | Pkg.describe "shell" @@ fun c -> 10 | let unix = Conf.value c unix in 11 | Ok [ 12 | Pkg.mllib "src/shell.mllib"; 13 | Pkg.mllib ~cond:unix "unix/shell_unix.mllib"; 14 | ] 15 | -------------------------------------------------------------------------------- /src/shell.ml: -------------------------------------------------------------------------------- 1 | module Commands = Shell_commands 2 | module Types = Shell_types 3 | module State = Shell_state 4 | module Lexer = Shell_lexer 5 | module Ast = Shell_ast 6 | module Eval = Shell_eval 7 | module Predictions = Shell_predictions 8 | module Highlight = Shell_highlight 9 | module History = Shell_history 10 | -------------------------------------------------------------------------------- /src/shell.mli: -------------------------------------------------------------------------------- 1 | module Commands = Shell_commands 2 | module Types = Shell_types 3 | module State = Shell_state 4 | module Lexer = Shell_lexer 5 | module Ast = Shell_ast 6 | module Eval = Shell_eval 7 | module Predictions = Shell_predictions 8 | module Highlight = Shell_highlight 9 | module History = Shell_history 10 | -------------------------------------------------------------------------------- /src/shell.mllib: -------------------------------------------------------------------------------- 1 | Shell 2 | Shell_commands 3 | Shell_types 4 | Shell_state 5 | Shell_lexer 6 | Shell_ast 7 | Shell_eval 8 | Shell_predictions 9 | Shell_highlight 10 | Shell_history 11 | -------------------------------------------------------------------------------- /src/shell_ast.ml: -------------------------------------------------------------------------------- 1 | open Shell_commands 2 | open Shell_types 3 | module L = Shell_lexer 4 | 5 | type loc = int * int 6 | 7 | type expr = 8 | | Empty of loc 9 | | Unknown_command of ustring * loc * arg list 10 | | Command of Command.full * ustring * loc * arg list 11 | | Statement of expr * loc * expr 12 | 13 | and arg = 14 | | Unknown_opt of ustring * loc 15 | | Known_opt of Arg.Opt.t * ustring * loc * (ustring * loc) option 16 | | Unknown_pos_or_value of ustring * loc 17 | | Unknown_pos of ustring * loc 18 | | Known_pos of Arg.Pos.t * ustring * loc 19 | 20 | let raw (lexer, _) = L.peek lexer |> L.raw 21 | let loc (lexer, _) = let tok = L.peek lexer in (L.start_pos tok, L.end_pos tok) 22 | let commands (_, commands) = commands 23 | let next (lexer, commands) = (L.next lexer, commands) 24 | 25 | let (>>=) (value, state) f = (f value, state) 26 | 27 | let dash = 0x2d 28 | 29 | let sub_ustring us start = Array.sub us start (Array.length us - start) 30 | 31 | let is_long_name w = Array.length w >= 2 && w.(0) = dash && w.(1) = dash 32 | 33 | let is_short_name w = 34 | Array.length w >= 1 && w.(0) = dash && 35 | (Array.length w = 1 || w.(1) <> dash) 36 | 37 | let get_args w loc = 38 | if is_long_name w then [Unknown_opt (sub_ustring w 2, loc)] 39 | else if is_short_name w then 40 | [Unknown_opt (sub_ustring w 1, loc)] 41 | else [Unknown_pos_or_value (w, loc)] 42 | 43 | let rec parse_args state = 44 | match raw state with 45 | | L.END | L.SEMICOLON -> [], state 46 | | L.WORD w -> 47 | parse_args (next state) >>= fun args -> 48 | get_args w (loc state) @ args 49 | 50 | let rec lookup_args i command = function 51 | | [] -> [] 52 | | Unknown_pos (us, loc)::tl | Unknown_pos_or_value (us, loc)::tl -> 53 | let hd = 54 | match command |> Command.lookup_pos i with 55 | | None -> Unknown_pos (us, loc) 56 | | Some pos -> Known_pos (pos, us, loc) 57 | in hd :: lookup_args (i + 1) command tl 58 | | (Unknown_opt (us, loc) as hd)::tl -> 59 | begin 60 | match command |> Command.lookup_opt (string_of_ustring us) with 61 | | None -> hd :: lookup_args i command tl 62 | | Some opt -> 63 | let value_o, tl = 64 | if Arg.Opt.is_flag opt then None, tl 65 | else 66 | match tl with 67 | | Unknown_pos_or_value (us, loc) :: tl -> Some (us, loc), tl 68 | | _ -> None, tl 69 | in 70 | Known_opt (opt, us, loc, value_o) :: lookup_args i command tl 71 | end 72 | | hd::tl -> hd :: lookup_args i command tl 73 | 74 | let parse_command name loc state = 75 | parse_args state >>= fun args -> 76 | match commands state |> Map.get (string_of_ustring name) with 77 | | None -> Unknown_command (name, loc, args) 78 | | Some c -> Command (c, name, loc, lookup_args 0 c args) 79 | 80 | let rec parse_expr state = 81 | match raw state with 82 | | L.END | L.SEMICOLON -> 83 | let pos, _ = loc state in parse_op (Empty (pos, pos)) state 84 | | L.WORD w -> 85 | let left, state = parse_command w (loc state) (next state) in 86 | parse_op left state 87 | 88 | and parse_op left state = 89 | match raw state with 90 | | L.END -> left, state 91 | | L.SEMICOLON -> 92 | parse_expr (next state) >>= fun right -> 93 | Statement (left, loc state, right) 94 | | L.WORD _ -> assert false 95 | 96 | type t = { 97 | e : expr; 98 | uchars : uchar list; 99 | terminated : bool; 100 | commands : Map.t; 101 | } 102 | 103 | let create commands = { 104 | e = Empty (0, 0); 105 | uchars = []; 106 | terminated = true; 107 | commands; 108 | } 109 | 110 | let create_gen l = 111 | let r = ref l in 112 | fun () -> 113 | match !r with 114 | | [] -> None 115 | | hd::tl -> r := tl; Some hd 116 | 117 | let update uchars {commands; _} = 118 | let lexer = L.from_gen (create_gen uchars) in 119 | let e, (lexer, _) = parse_expr (lexer, commands) in 120 | let terminated = L.is_terminated lexer in 121 | {e; uchars; terminated; commands} 122 | 123 | let test s = 124 | let decoder = Uutf.decoder (`String s) in 125 | let rec aux () = 126 | match Uutf.decode decoder with 127 | | `Await | `Malformed _ -> failwith "" 128 | | `End -> [] 129 | | `Uchar u -> u :: aux () 130 | in 131 | let t = create (Map.empty) in 132 | update (aux ()) t 133 | 134 | let get_expr {e; _} = e 135 | let get_uchars {uchars; _} = uchars 136 | let get_commands {commands; _} = commands 137 | let is_terminated {terminated; _} = terminated 138 | -------------------------------------------------------------------------------- /src/shell_ast.mli: -------------------------------------------------------------------------------- 1 | open Shell_commands 2 | open Shell_types 3 | 4 | type t 5 | 6 | type loc = int * int 7 | 8 | type expr = 9 | | Empty of loc 10 | | Unknown_command of ustring * loc * arg list 11 | | Command of Command.full * ustring * loc * arg list 12 | | Statement of expr * loc * expr 13 | 14 | and arg = 15 | | Unknown_opt of ustring * loc 16 | | Known_opt of Arg.Opt.t * ustring * loc * (ustring * loc) option 17 | | Unknown_pos_or_value of ustring * loc 18 | | Unknown_pos of ustring * loc 19 | | Known_pos of Arg.Pos.t * ustring * loc 20 | 21 | val create : Shell_commands.Map.t -> t 22 | 23 | val update : uchar list -> t -> t 24 | 25 | val test : string -> t 26 | 27 | val get_expr : t -> expr 28 | 29 | val get_uchars : t -> uchar list 30 | 31 | val get_commands : t -> Shell_commands.Map.t 32 | 33 | val is_terminated : t -> bool 34 | -------------------------------------------------------------------------------- /src/shell_commands.ml: -------------------------------------------------------------------------------- 1 | module String_map = struct 2 | include Map.Make (String) 3 | 4 | let add_all_keys ks v t = 5 | ks |> List.fold_left (fun t k -> t |> add k v) t 6 | 7 | let safe_find s t = try Some (t |> find s) with Not_found -> None 8 | end 9 | 10 | let rec get n = function 11 | | [] -> None 12 | | hd::tl -> if n <= 0 then Some hd else tl |> get (n - 1) 13 | 14 | module Arg = struct 15 | type info = { 16 | doc : string; 17 | predict : (string -> string list) option; 18 | } 19 | 20 | module Opt = struct 21 | type t = { 22 | names : string list; 23 | is_flag : bool; 24 | info : info; 25 | } 26 | 27 | let create names ~is_flag info = { 28 | names; 29 | is_flag; 30 | info 31 | } 32 | 33 | let names {names; _} = names 34 | 35 | let is_flag {is_flag; _} = is_flag 36 | 37 | let info {info; _} = info 38 | end 39 | 40 | module Pos = struct 41 | type t = { 42 | info : info 43 | } 44 | 45 | let create info = {info} 46 | 47 | let info {info; _} = info 48 | end 49 | 50 | type arg = [`Opt of Opt.t | `Pos of Pos.t] 51 | 52 | let info = function 53 | | `Opt opt -> Opt.info opt 54 | | `Pos pos -> Pos.info pos 55 | 56 | let doc arg = (info arg).doc 57 | 58 | let predict prefix arg = 59 | match (info arg).predict with 60 | | None -> [] 61 | | Some f -> f prefix 62 | 63 | type 'a t = [ 64 | | `Opt_value of Opt.t * (string option -> 'a) 65 | | `Pos_value of Pos.t * (string option -> 'a) 66 | | `Const of 'a 67 | ] 68 | 69 | let flag ?(doc="") names : bool t = 70 | let opt = Opt.create names ~is_flag:true {doc; predict = None} in 71 | `Opt_value (opt, fun o -> o <> None) 72 | 73 | let opt ?(doc="") ?predict ?(default="") names : string t = 74 | let opt = Opt.create names ~is_flag:false {doc; predict} in 75 | `Opt_value (opt, function None -> default | Some s -> s) 76 | 77 | let pos ?(doc="") ?predict ?(default="") () : string t = 78 | let pos = Pos.create {doc; predict} in 79 | `Pos_value (pos, function None -> default | Some s -> s) 80 | 81 | let pos_required ?(doc="") ?predict () : string t = 82 | let pos = Pos.create {doc; predict} in 83 | `Pos_value (pos, function None -> "" | Some s -> s) 84 | end 85 | 86 | module Values = struct 87 | type t = { 88 | opt_values : string String_map.t; 89 | pos_values : string list; 90 | } 91 | 92 | let empty = { 93 | opt_values = String_map.empty; 94 | pos_values = []; 95 | } 96 | 97 | let opt_name opt = 98 | match Arg.Opt.names opt with 99 | | [] -> "" 100 | | hd::_ -> hd 101 | 102 | let opt opt {opt_values; _} = 103 | opt_values |> String_map.safe_find (opt_name opt) 104 | 105 | let pos_index i {pos_values; _} = 106 | pos_values |> get i 107 | 108 | let prepend_opt opt v ({opt_values; _} as t) = 109 | if opt_values |> String_map.mem (opt_name opt) then t 110 | else 111 | let opt_values = opt_values |> String_map.add (opt_name opt) v in 112 | {t with opt_values} 113 | 114 | let prepend_pos_value v ({pos_values; _} as t) = 115 | let pos_values = v :: pos_values in 116 | {t with pos_values} 117 | end 118 | 119 | module Command = struct 120 | type 'a t = { 121 | name : string; 122 | opt_map : Arg.Opt.t String_map.t; 123 | pos_list : Arg.Pos.t list; 124 | doc : string; 125 | execute : Values.t -> 'a; 126 | should_exit : bool; 127 | } 128 | 129 | type full = unit Lwt.t t 130 | 131 | let create ?(doc="") name f = { 132 | name; 133 | opt_map = String_map.empty; 134 | pos_list = []; 135 | doc; 136 | execute = (fun _values -> f); 137 | should_exit = false; 138 | } 139 | 140 | let name {name; _} = name 141 | 142 | let rename name t = {t with name} 143 | 144 | let ($) (({opt_map; pos_list; execute; _} as t)) = function 145 | | `Opt_value (opt, value_f) -> 146 | let opt_map = 147 | opt_map |> String_map.add_all_keys (Arg.Opt.names opt) opt 148 | in 149 | let execute values = 150 | values |> Values.opt opt |> value_f |> execute values 151 | in 152 | {t with opt_map; execute} 153 | | `Pos_value (pos, value_f) -> 154 | let execute values = 155 | let i = List.length pos_list in 156 | values |> Values.pos_index i |> value_f |> execute values 157 | in 158 | let pos_list = pos_list @ [pos] in 159 | {t with pos_list; execute} 160 | | `Const v -> 161 | let execute values = execute values v in 162 | {t with execute} 163 | 164 | let const v = `Const v 165 | 166 | let map f ({execute; _} as t) = 167 | let execute values = execute values |> f in 168 | {t with execute} 169 | 170 | let exit = {(create "exit" Lwt.return_unit) with should_exit = true} 171 | 172 | let eval value_pairs {execute; _} = 173 | let values = List.fold_right (fun (arg, v) values -> 174 | match arg with 175 | | `Opt opt -> values |> Values.prepend_opt opt v 176 | | `Pos _ -> values |> Values.prepend_pos_value v 177 | ) value_pairs Values.empty 178 | in 179 | execute values 180 | 181 | let doc {doc; _} = doc 182 | 183 | let lookup_pos i {pos_list; _} = pos_list |> get i 184 | 185 | let lookup_opt name {opt_map; _} = opt_map |> String_map.safe_find name 186 | 187 | let opt_bindings {opt_map; _} = opt_map |> String_map.bindings 188 | 189 | let should_exit {should_exit; _} = should_exit 190 | end 191 | 192 | module Map = struct 193 | type t = unit Lwt.t Command.t String_map.t 194 | 195 | let add command t = t |> String_map.add (Command.name command) command 196 | 197 | let empty = String_map.empty |> add Command.exit 198 | 199 | let get name t = t |> String_map.safe_find name 200 | 201 | let bindings t = t |> String_map.bindings 202 | end 203 | -------------------------------------------------------------------------------- /src/shell_commands.mli: -------------------------------------------------------------------------------- 1 | module Arg : sig 2 | type 'a t 3 | 4 | val flag : ?doc:string -> string list -> bool t 5 | 6 | val opt : ?doc:string -> ?predict:(string -> string list) -> 7 | ?default:string -> string list -> string t 8 | 9 | val pos : ?doc:string -> ?predict:(string -> string list) -> 10 | ?default:string -> unit -> string t 11 | 12 | val pos_required : ?doc:string -> ?predict:(string -> string list) -> 13 | unit -> string t 14 | 15 | module Opt : sig 16 | type t 17 | val is_flag : t -> bool 18 | end 19 | module Pos : sig type t end 20 | type arg = [`Opt of Opt.t | `Pos of Pos.t] 21 | val doc : arg -> string 22 | val predict : string -> arg -> string list 23 | end 24 | 25 | module Command : sig 26 | type 'a t 27 | 28 | type full = unit Lwt.t t 29 | 30 | val name : 'a t -> string 31 | 32 | val rename : string -> 'a t -> 'a t 33 | 34 | val create : ?doc:string -> string -> 'a -> 'a t 35 | 36 | val ($) : ('a -> 'b) t -> 'a Arg.t -> 'b t 37 | 38 | val const : 'a -> 'a Arg.t 39 | 40 | val map : ('a -> 'b) -> 'a t -> 'b t 41 | 42 | val eval : (Arg.arg * string) list -> 'a t -> 'a 43 | val doc : 'a t -> string 44 | val lookup_opt : string -> 'a t -> Arg.Opt.t option 45 | val lookup_pos : int -> 'a t -> Arg.Pos.t option 46 | val opt_bindings : 'a t -> (string * Arg.Opt.t) list 47 | val should_exit : 'a t -> bool 48 | end 49 | 50 | module Map : sig 51 | type t 52 | 53 | val empty : t 54 | 55 | val add : Command.full -> t -> t 56 | 57 | val get : string -> t -> Command.full option 58 | val bindings : t -> (string * Command.full) list 59 | end 60 | -------------------------------------------------------------------------------- /src/shell_eval.ml: -------------------------------------------------------------------------------- 1 | open Shell_commands 2 | open Shell_ast 3 | open Shell_types 4 | open Lwt.Infix 5 | open Result 6 | 7 | type info = { 8 | commands : Map.t; 9 | print_error : string -> unit Lwt.t 10 | } 11 | 12 | let print_error {print_error; _} s = print_error s 13 | 14 | let process_args args = 15 | let rec aux acc = function 16 | | [] -> Ok (List.rev acc) 17 | | Known_pos (pos, us, _)::tl -> 18 | aux ((`Pos pos, string_of_ustring us) :: acc) tl 19 | | Known_opt (opt, _, _, value_o)::tl -> 20 | let opt = 21 | match value_o with 22 | | None -> (`Opt opt, "") 23 | | Some (us, _) -> (`Opt opt, string_of_ustring us) 24 | in 25 | aux (opt::acc) tl 26 | | _ -> Error "Unknown arg." 27 | in 28 | aux [] args 29 | 30 | let rec eval_expr info = function 31 | | Empty _ -> Lwt.return `Continue 32 | | Statement (left, _, right) -> 33 | begin 34 | eval_expr info left >>= function 35 | | `Exit -> Lwt.return `Exit 36 | | `Continue -> eval_expr info right 37 | end 38 | | Unknown_command (us, _, _) -> 39 | "Unknown command '" ^ string_of_ustring us ^ "'." |> 40 | print_error info >|= fun () -> `Continue 41 | | Command (command, _, _, args) -> 42 | begin 43 | match process_args args with 44 | | Error msg -> msg |> print_error info >|= fun () -> `Continue 45 | | Ok processed -> 46 | let execute () = command |> Command.eval processed in 47 | let handle_exn exn = Printexc.to_string exn |> print_error info in 48 | Lwt.catch execute handle_exn >|= fun () -> 49 | if Command.should_exit command then `Exit else `Continue 50 | end 51 | 52 | let eval ~print_error ast = 53 | if not (Shell_ast.is_terminated ast) then 54 | "Input isn't terminated." |> print_error >|= fun () -> `Continue 55 | else 56 | let commands = Shell_ast.get_commands ast in 57 | let e = Shell_ast.get_expr ast in 58 | eval_expr {commands; print_error} e 59 | -------------------------------------------------------------------------------- /src/shell_eval.mli: -------------------------------------------------------------------------------- 1 | 2 | (* Returns a thread that returns true if the shell should exit. *) 3 | val eval : print_error:(string -> unit Lwt.t) -> Shell_ast.t -> 4 | [`Exit | `Continue] Lwt.t 5 | -------------------------------------------------------------------------------- /src/shell_highlight.ml: -------------------------------------------------------------------------------- 1 | open Shell_ast 2 | open Shell_types 3 | 4 | type syntax = [ 5 | | `White_space 6 | | `Operator 7 | | `Command_name 8 | | `Opt_name 9 | | `Opt_value 10 | | `Pos_value 11 | | `Unknown 12 | ] 13 | 14 | type state = { 15 | uchars : uchar list; 16 | pos : int; 17 | acc : (syntax * ustring) list; 18 | } 19 | 20 | let highlight_loc syn (start_pos, end_pos) {uchars; pos; acc} = 21 | let rec split n l = 22 | if n <= 0 then [], l else 23 | match l with 24 | | [] -> [], [] 25 | | hd::tl -> let ls, rs = split (n - 1) tl in (hd::ls, rs) 26 | in 27 | let aux n uchars = 28 | let ls, uchars = split n uchars in 29 | Array.of_list ls, uchars 30 | in 31 | let ws, uchars = aux (start_pos - pos) uchars in 32 | let us, uchars = aux (end_pos - start_pos) uchars in 33 | let acc = 34 | if Array.length ws = 0 then (syn, us) :: acc 35 | else (syn, us) :: (`White_space, ws) :: acc 36 | in 37 | {uchars; pos = end_pos; acc} 38 | 39 | let highlight_arg arg state = 40 | match arg with 41 | | Unknown_opt (_, loc) 42 | | Unknown_pos_or_value (_, loc) 43 | | Unknown_pos (_, loc) -> state |> highlight_loc `Unknown loc 44 | | Known_opt (_, _, loc, None) -> state |> highlight_loc `Opt_name loc 45 | | Known_pos (_, _, loc) -> state |> highlight_loc `Pos_value loc 46 | | Known_opt (_, _, loc, Some (_, v_loc)) -> 47 | state |> highlight_loc `Opt_name loc |> highlight_loc `Opt_value v_loc 48 | 49 | let rec highlight_args args state = 50 | match args with 51 | | [] -> state 52 | | hd::tl -> state |> highlight_arg hd |> highlight_args tl 53 | 54 | let rec highlight_expr e state = 55 | match e with 56 | | Empty loc -> state |> highlight_loc `White_space loc 57 | | Statement (left, loc, right) -> 58 | state |> highlight_expr left 59 | |> highlight_loc `Operator loc 60 | |> highlight_expr right 61 | | Unknown_command (_, loc, args) -> 62 | state |> highlight_loc `Unknown loc |> highlight_args args 63 | | Command (_, _, loc, args) -> 64 | state |> highlight_loc `Command_name loc |> highlight_args args 65 | 66 | let for_ast ast ~f = 67 | let e = get_expr ast in 68 | let uchars = get_uchars ast in 69 | let {acc; uchars; _} = highlight_expr e {uchars; pos = 0; acc = []} in 70 | let acc = (`White_space, Array.of_list uchars) :: acc in 71 | List.rev_map (fun (syn, ustring) -> f ustring syn) acc 72 | -------------------------------------------------------------------------------- /src/shell_highlight.mli: -------------------------------------------------------------------------------- 1 | open Shell_types 2 | 3 | type syntax = [ 4 | | `White_space 5 | | `Operator 6 | | `Command_name 7 | | `Opt_name 8 | | `Opt_value 9 | | `Pos_value 10 | | `Unknown 11 | ] 12 | 13 | val for_ast : Shell_ast.t -> f:(ustring -> syntax -> 'a) -> 'a list 14 | -------------------------------------------------------------------------------- /src/shell_history.ml: -------------------------------------------------------------------------------- 1 | open Shell_types 2 | 3 | type entry = string 4 | 5 | type t = { 6 | up : entry list; 7 | down : entry list; 8 | } 9 | 10 | let wrap l = Array.of_list l |> string_of_ustring 11 | 12 | let unwrap entry = ustring_of_string entry |> Array.to_list 13 | 14 | let empty = { 15 | up = []; 16 | down = []; 17 | } 18 | 19 | let add current {up; down} = 20 | let up = wrap current :: List.rev_append down up in 21 | {up; down = []} 22 | 23 | let up current {up; down} = 24 | match up with 25 | | [] -> None 26 | | hd::tl -> Some (unwrap hd, {up = tl; down = wrap current :: down}) 27 | 28 | let down current {up; down} = 29 | match down with 30 | | [] -> None 31 | | hd::tl -> Some (unwrap hd, {up = wrap current :: up; down = tl}) 32 | -------------------------------------------------------------------------------- /src/shell_history.mli: -------------------------------------------------------------------------------- 1 | open Shell_types 2 | 3 | type t 4 | 5 | val empty : t 6 | 7 | val add : uchar list -> t -> t 8 | 9 | val up : uchar list -> t -> (uchar list * t) option 10 | 11 | val down : uchar list -> t -> (uchar list * t) option 12 | -------------------------------------------------------------------------------- /src/shell_lexer.ml: -------------------------------------------------------------------------------- 1 | open Shell_types 2 | 3 | type raw_token = 4 | | WORD of ustring 5 | | SEMICOLON 6 | | END 7 | 8 | let rev_array_concat l = List.rev l |> Array.concat 9 | 10 | let lexeme = Sedlexing.lexeme 11 | let sub_lexeme = Sedlexing.sub_lexeme 12 | let get_pos = Sedlexing.lexeme_end 13 | 14 | let special = [%sedlex.regexp? ';'] 15 | let bare_other = [%sedlex.regexp? white_space | '"' | '\\' | special] 16 | let string_other = [%sedlex.regexp? '"' | '\\'] 17 | 18 | let rec lex_bare buf acc = 19 | match%sedlex buf with 20 | | '"' -> lex_string buf acc 21 | | '\\', eof -> WORD (rev_array_concat acc), false 22 | | '\\', any -> lex_bare buf (sub_lexeme buf 1 2 :: acc) 23 | | Plus (Compl bare_other) -> lex_bare buf (lexeme buf :: acc) 24 | | _ (* eof | white_space | special *) -> WORD (rev_array_concat acc), true 25 | 26 | and lex_string buf acc = 27 | match%sedlex buf with 28 | | '"' -> lex_bare buf acc 29 | | '\\', '"' -> lex_string buf @@ sub_lexeme buf 1 2 :: acc 30 | | '\\', any -> lex_string buf @@ lexeme buf :: acc 31 | | Plus (Compl string_other) -> lex_string buf @@ lexeme buf :: acc 32 | | _ (* eof *) -> WORD (rev_array_concat acc), false 33 | 34 | type token = raw_token * int * int 35 | 36 | let rec lex buf = 37 | let start_pos = get_pos buf in 38 | let emit raw = (raw, start_pos, get_pos buf), true in 39 | let emit_word lex_word = 40 | let word, term = lex_word buf [] in 41 | (word, start_pos, get_pos buf), term 42 | in 43 | match%sedlex buf with 44 | | Plus (white_space | "\\\n") -> lex buf 45 | | eof -> emit END 46 | | ';' -> emit SEMICOLON 47 | | special -> assert false 48 | | '"' -> emit_word lex_string 49 | | _ -> emit_word lex_bare 50 | 51 | type t = { 52 | buf : Sedlexing.lexbuf; 53 | curr : token; 54 | terminated : bool; 55 | } 56 | 57 | let from_gen gen = 58 | let buf = Sedlexing.from_gen gen in 59 | let curr, terminated = lex buf in 60 | {buf; curr; terminated} 61 | 62 | let peek {curr; _} = curr 63 | 64 | let next ({buf; terminated; _} as t) = 65 | let curr, term = lex buf in 66 | {t with curr; terminated = terminated && term} 67 | 68 | let is_terminated {terminated; _} = terminated 69 | 70 | let raw (raw, _, _) = raw 71 | let start_pos (_, start_pos, _) = start_pos 72 | let end_pos (_, _, end_pos) = end_pos 73 | 74 | let escape_string us = 75 | let backslash = 0x5C in 76 | let double_quote = 0x22 in 77 | let rec aux buf acc = 78 | match%sedlex buf with 79 | | string_other -> lexeme buf :: [|backslash|] :: acc |> aux buf 80 | | Plus (Compl string_other) -> lexeme buf :: acc |> aux buf 81 | | _ (* eof *) -> [|double_quote|] :: acc |> rev_array_concat 82 | in 83 | [|double_quote|] :: [] |> aux (Sedlexing.from_int_array us) 84 | 85 | let escape_word us = 86 | let rec should_string buf = 87 | match%sedlex buf with 88 | | bare_other -> true 89 | | any -> should_string buf 90 | | _ (* eof *) -> false 91 | in 92 | if should_string (Sedlexing.from_int_array us) then escape_string us else us 93 | -------------------------------------------------------------------------------- /src/shell_lexer.mli: -------------------------------------------------------------------------------- 1 | open Shell_types 2 | 3 | type t 4 | 5 | type raw_token = 6 | | WORD of ustring 7 | | SEMICOLON 8 | | END 9 | 10 | type token 11 | 12 | val from_gen : uchar_gen -> t 13 | 14 | val peek : t -> token 15 | val next : t -> t 16 | val is_terminated : t -> bool 17 | 18 | val raw : token -> raw_token 19 | val start_pos : token -> int 20 | val end_pos : token -> int 21 | 22 | val escape_word : ustring -> ustring 23 | -------------------------------------------------------------------------------- /src/shell_predictions.ml: -------------------------------------------------------------------------------- 1 | open Shell_commands 2 | open Shell_ast 3 | open Shell_types 4 | 5 | type prediction = { 6 | raw : string; 7 | doc : string; 8 | process : (string -> string) option 9 | } 10 | 11 | let raw {raw; _} = raw 12 | 13 | let doc {doc; _} = doc 14 | 15 | let escape_to_ustring {raw; process; _} = 16 | let raw = match process with Some f -> f raw | None -> raw in 17 | let us = ustring_of_string raw |> Shell_lexer.escape_word in 18 | let len = Array.length us in 19 | if len >= 2 && us.(0) = 0x22 && us.(len - 1) = 0x22 (* "\"" *) then 20 | Array.sub us 0 (len - 1) 21 | else us 22 | 23 | type t = { 24 | predictions : prediction list; 25 | kind : [`Names | `Values | `Invalid]; 26 | doc_all : string; 27 | loc : int * int; 28 | } 29 | 30 | let to_list {predictions; _} = predictions 31 | 32 | let kind {kind; _} = kind 33 | 34 | let doc_all {doc_all; _} = doc_all 35 | 36 | let replacing_location {loc; _} = loc 37 | 38 | let longest_prefix t = 39 | (* The predictions are in alphabetical order, so just need to find the 40 | longest prefix of the first and last predictions. *) 41 | match t |> to_list with 42 | | [] -> None 43 | | a::tl -> 44 | match List.rev tl with 45 | | [] -> Some (escape_to_ustring a) 46 | | b::_ -> 47 | let rec aux a b i max = 48 | if i = max || a.(i) <> b.(i) then [] 49 | else a.(i) :: aux a b (i + 1) max 50 | in 51 | let a = escape_to_ustring a in 52 | let b = escape_to_ustring b in 53 | let max = min (Array.length a) (Array.length b) in 54 | Some (aux a b 0 max |> Array.of_list) 55 | 56 | let make_invalid ~loc = { 57 | predictions = []; 58 | kind = `Invalid; 59 | doc_all = ""; 60 | loc; 61 | } 62 | 63 | (* Note that this returns false in the case when the string is equal to 64 | the prefix. This is intended. *) 65 | let has_prefix prefix s = 66 | let len = String.length prefix in 67 | String.length s > len && String.sub s 0 len = prefix 68 | 69 | let filter_bindings prefix_us l = 70 | if Array.length prefix_us = 0 then l 71 | else 72 | let prefix = string_of_ustring prefix_us in 73 | l |> List.filter (fun (k, _) -> k |> has_prefix prefix) 74 | 75 | let predict_name ?process prefix ~loc ~bindings ~doc_f = 76 | let predictions = 77 | bindings |> filter_bindings prefix |> 78 | List.map (fun (raw, v) -> {raw; doc = doc_f v; process}) 79 | in 80 | {predictions; kind = `Names; doc_all = "Possible names."; loc} 81 | 82 | let predict_opt_name name ~loc command = 83 | let process name = 84 | (if String.length name = 1 then "-" else "--") ^ name 85 | in 86 | let bindings = command |> Command.opt_bindings in 87 | let doc_f opt = Arg.doc (`Opt opt) in 88 | predict_name name ~loc ~bindings ~doc_f ~process 89 | 90 | let predict_command name ~loc commands = 91 | let bindings = commands |> Map.bindings in 92 | predict_name name ~loc ~bindings ~doc_f:Command.doc 93 | 94 | let predict_value value ~loc arg = 95 | let doc = Arg.doc arg in 96 | let predictions = 97 | arg |> Arg.predict (string_of_ustring value) |> 98 | List.filter (has_prefix @@ string_of_ustring value) |> 99 | List.sort String.compare |> 100 | List.map (fun raw -> {raw; doc; process = None}) 101 | in 102 | {predictions; kind = `Values; doc_all = doc; loc} 103 | 104 | let predict_opt_value value ~loc opt = 105 | `Opt opt |> predict_value value ~loc 106 | 107 | let predict_pos_value value ~loc pos = 108 | `Pos pos |> predict_value value ~loc 109 | 110 | let predict_unknown i ~loc command = 111 | match command |> Command.lookup_pos i with 112 | | None -> command |> predict_opt_name [||] ~loc 113 | | Some pos_arg -> pos_arg |> predict_pos_value [||] ~loc 114 | 115 | let is_before (start_pos, _) pos = pos < start_pos 116 | 117 | let is_after (_, end_pos) pos = pos > end_pos 118 | 119 | let rec predict_arg command pos i args = 120 | let default () = command |> predict_unknown i ~loc:(pos, pos) in 121 | let when_is_in loc ~do_f ?(incr=false) ~tl pos = 122 | if pos |> is_before loc then default () 123 | else if pos |> is_after loc then 124 | predict_arg command pos (if incr then i + 1 else i) tl 125 | else do_f () 126 | in 127 | match args with 128 | | [] -> default () 129 | | Unknown_pos_or_value (_, loc) :: tl 130 | | Unknown_pos (_, loc) :: tl -> 131 | pos |> when_is_in loc ~do_f:(fun () -> 132 | make_invalid ~loc 133 | ) ~incr:true ~tl 134 | | Unknown_opt (name, loc) :: tl -> 135 | pos |> when_is_in loc ~do_f:(fun () -> 136 | command |> predict_opt_name name ~loc 137 | ) ~tl 138 | | Known_pos (pos_arg, value, loc) :: tl -> 139 | pos |> when_is_in loc ~do_f:(fun () -> 140 | pos_arg |> predict_pos_value value ~loc 141 | ) ~incr:true ~tl 142 | | Known_opt (opt, name, loc, value_o) :: tl -> 143 | if pos |> is_before loc then default () 144 | else if pos |> is_after loc then begin 145 | match value_o with 146 | | None -> 147 | if Arg.Opt.is_flag opt then default () 148 | else opt |> predict_opt_value [||] ~loc:(pos, pos) 149 | | Some (value, value_loc) -> 150 | if pos |> is_before value_loc then 151 | opt |> predict_opt_value [||] ~loc 152 | else if pos |> is_after value_loc then predict_arg command pos i tl 153 | else opt |> predict_opt_value value ~loc 154 | end else command |> predict_opt_name name ~loc 155 | 156 | let rec predict_expr commands pos e = 157 | let default () = commands |> predict_command [||] ~loc:(pos, pos) in 158 | match e with 159 | | Empty _ -> default () 160 | | Statement (left, loc, right) -> 161 | if pos |> is_before loc then predict_expr commands pos left 162 | else if pos |> is_after loc then predict_expr commands pos right 163 | else default () 164 | | Unknown_command (name, loc, _) -> 165 | if pos |> is_before loc then default () 166 | else if pos |> is_after loc then make_invalid ~loc 167 | else commands |> predict_command name ~loc 168 | | Command (command, name, loc, args) -> 169 | if pos |> is_before loc then default () 170 | else if pos |> is_after loc then predict_arg command pos 0 args 171 | else commands |> predict_command name ~loc 172 | 173 | let at_position pos ast = 174 | let e = get_expr ast in 175 | let commands = get_commands ast in 176 | predict_expr commands pos e 177 | -------------------------------------------------------------------------------- /src/shell_predictions.mli: -------------------------------------------------------------------------------- 1 | open Shell_types 2 | 3 | type t 4 | 5 | type prediction 6 | 7 | val replacing_location : t -> int * int 8 | 9 | (** The list of prediction values, sorted by their raw string value. *) 10 | val to_list : t -> prediction list 11 | 12 | val kind : t -> [`Names | `Values | `Invalid] 13 | 14 | val doc_all : t -> string 15 | 16 | val longest_prefix : t -> ustring option 17 | 18 | val at_position : int -> Shell_ast.t -> t 19 | 20 | val raw : prediction -> string 21 | 22 | val doc : prediction -> string 23 | 24 | val escape_to_ustring : prediction -> ustring 25 | -------------------------------------------------------------------------------- /src/shell_state.ml: -------------------------------------------------------------------------------- 1 | open Shell_types 2 | module Ast = Shell_ast 3 | module Predictions = Shell_predictions 4 | module History = Shell_history 5 | 6 | type t = { 7 | left : uchar list; 8 | right : uchar list; 9 | pos : int; 10 | history : History.t; 11 | full : uchar list Lazy.t; 12 | ast : Ast.t Lazy.t; 13 | predictions : Predictions.t Lazy.t; 14 | } 15 | 16 | let create commands = 17 | let ast = Ast.create commands in { 18 | (* Reverse ordered, so (List.rev left) @ right gives the whole input. *) 19 | left = []; 20 | right = []; 21 | full = lazy ([]); 22 | pos = 0; 23 | ast = lazy (ast); 24 | predictions = lazy (ast |> Predictions.at_position 0); 25 | history = History.empty; 26 | } 27 | 28 | let pos {pos; _} = pos 29 | 30 | let move_left ({left; right; pos; _} as t) = 31 | match left with 32 | | [] -> t 33 | | hd::tl -> {t with left = tl; right = hd::right; pos = pos - 1} 34 | 35 | let move_right ({left; right; pos; _} as t) = 36 | match right with 37 | | [] -> t 38 | | hd::tl -> {t with left = hd::left; right = tl; pos = pos + 1} 39 | 40 | let fix ({left; right; ast; pos; _} as t) = 41 | let full = lazy (List.rev_append left right) in 42 | let ast = lazy (Lazy.force ast |> Ast.update (Lazy.force full)) in 43 | let predictions = lazy (Lazy.force ast |> Predictions.at_position pos) in 44 | {t with full; ast; predictions} 45 | 46 | let insert_uchar u ({left; pos; _} as t) = 47 | {t with left = u::left; pos = pos + 1} |> fix 48 | 49 | let forward_delete_uchar ({right; _} as t) = 50 | match right with 51 | | [] -> t 52 | | _::tl -> {t with right = tl} |> fix 53 | 54 | let backward_delete_uchar ({left; pos; _} as t) = 55 | match left with 56 | | [] -> t 57 | | _::tl -> {t with left = tl; pos = pos - 1} |> fix 58 | 59 | let input_is_terminated {ast; _} = Ast.is_terminated (Lazy.force ast) 60 | 61 | let modify_history history_f ({history; full; _} as t) = 62 | match history |> history_f (Lazy.force full) with 63 | | None -> t 64 | | Some (l, history) -> { 65 | t with 66 | left = List.rev l; 67 | right = []; 68 | pos = List.length l; 69 | history 70 | } |> fix 71 | 72 | let history_up t = t |> modify_history History.up 73 | 74 | let history_down t = t |> modify_history History.down 75 | 76 | let execute ~print_error {full; ast; history; _} = 77 | let open Lwt.Infix in 78 | let ast = Lazy.force ast in 79 | Shell_eval.eval ~print_error ast >|= fun should_exit -> 80 | let state = Ast.get_commands ast |> create in 81 | let history = history |> History.add (Lazy.force full) in 82 | {state with history}, should_exit 83 | 84 | let highlight f {ast; _} = Shell_highlight.for_ast (Lazy.force ast) ~f 85 | 86 | let predictions {predictions; _} = Lazy.force predictions 87 | 88 | let apply_prediction_us us ({left; right; pos; predictions; _} as t) = 89 | let rec drop n = function 90 | | [] -> [] 91 | | _::tl as l -> if n <= 0 then l else drop (n - 1) tl 92 | in 93 | let predictions = Lazy.force predictions in 94 | let start_pos, end_pos = Predictions.replacing_location predictions in 95 | let left = left |> drop (pos - start_pos) in 96 | let left = us |> Array.fold_left (fun l u -> u::l) left in 97 | let right = right |> drop (end_pos - pos) in 98 | {t with left; right; pos = start_pos + Array.length us} |> fix 99 | 100 | let apply_predictions_longest_prefix ({predictions; _} as t) = 101 | match Predictions.longest_prefix (Lazy.force predictions) with 102 | | None -> t 103 | | Some us -> t |> apply_prediction_us us 104 | 105 | let apply_prediction prediction t = 106 | t |> apply_prediction_us (Predictions.escape_to_ustring prediction) 107 | -------------------------------------------------------------------------------- /src/shell_state.mli: -------------------------------------------------------------------------------- 1 | open Shell_types 2 | 3 | type t 4 | 5 | val create : Shell_commands.Map.t -> t 6 | 7 | val pos : t -> int 8 | 9 | val move_left : t -> t 10 | 11 | val move_right : t -> t 12 | 13 | val insert_uchar : int -> t -> t 14 | 15 | val backward_delete_uchar : t -> t 16 | 17 | val forward_delete_uchar : t -> t 18 | 19 | val input_is_terminated : t -> bool 20 | 21 | val history_up : t -> t 22 | 23 | val history_down : t -> t 24 | 25 | val execute : print_error:(string -> unit Lwt.t) -> t -> 26 | (t * [`Exit | `Continue]) Lwt.t 27 | 28 | val highlight : (ustring -> Shell_highlight.syntax -> 'a) -> t -> 'a list 29 | 30 | val predictions : t -> Shell_predictions.t 31 | 32 | val apply_predictions_longest_prefix : t -> t 33 | 34 | val apply_prediction : Shell_predictions.prediction -> t -> t 35 | -------------------------------------------------------------------------------- /src/shell_types.ml: -------------------------------------------------------------------------------- 1 | type uchar = int 2 | 3 | type ustring = uchar array 4 | 5 | type uchar_gen = unit -> uchar option 6 | 7 | let string_of_ustring ustring = 8 | let buffer = Buffer.create (Array.length ustring) in 9 | let add u = if Uutf.is_uchar u then Uutf.Buffer.add_utf_8 buffer u in 10 | ustring |> Array.iter add; 11 | Buffer.contents buffer 12 | 13 | let ustring_of_string s = 14 | let rec aux decoder = 15 | match Uutf.decode decoder with 16 | | `End -> [] 17 | | `Uchar u -> u :: aux decoder 18 | | `Malformed _ -> [] 19 | | `Await -> [] 20 | in 21 | `String s |> Uutf.decoder ~encoding:`UTF_8 |> aux |> Array.of_list 22 | -------------------------------------------------------------------------------- /src/shell_types.mli: -------------------------------------------------------------------------------- 1 | 2 | type uchar = int 3 | 4 | type ustring = uchar array 5 | 6 | type uchar_gen = unit -> uchar option 7 | 8 | (** Returns a UTF-8 string. Skips invalid uchars. *) 9 | val string_of_ustring : ustring -> string 10 | 11 | (** Assumes the input string is UTF-8 encoded. Stops at malformed characters. *) 12 | val ustring_of_string : string -> ustring 13 | -------------------------------------------------------------------------------- /unix/shell_unix.ml: -------------------------------------------------------------------------------- 1 | open Notty 2 | open Lwt.Infix 3 | module St = Shell_state 4 | module Predictions = Shell_predictions 5 | 6 | type action = 7 | | Execute 8 | | Complete 9 | | Apply of (St.t -> St.t) 10 | 11 | let print_error s = 12 | I.(string A.(st bold ++ fg red) "Error: " <|> string A.empty s) |> 13 | Notty_lwt.output_image_endline ~fd:Lwt_unix.stderr 14 | 15 | module Terminal = struct 16 | let esc s = "\x1b[" ^ s |> print_string 17 | 18 | let up () = esc "A" 19 | 20 | let delete_line () = esc "2K"; esc "G" 21 | 22 | let to_column n = 23 | let n = if n < 0 then 0 else n in 24 | esc (string_of_int n ^ "G") 25 | 26 | let width () = 27 | match Notty_lwt.winsize Lwt_unix.stdin with 28 | | None -> 80 29 | | Some (w, _) -> w 30 | end 31 | 32 | let highlighter us syn = 33 | let attr = 34 | let open A in 35 | match syn with 36 | | `Command_name -> fg blue 37 | | `Opt_name | `Opt_value -> fg green 38 | | `Pos_value -> empty 39 | | `Operator -> fg green 40 | | `Unknown -> fg red ++ st bold 41 | | `White_space -> fg yellow 42 | in 43 | I.uchars attr us 44 | 45 | let image_height = ref 0 46 | 47 | let draw ~prompt_f state = 48 | let wrap width image = 49 | let rec go off = I.hcrop off 0 image :: 50 | if I.width image - off > width then go (off + width) else [] 51 | in go 0 |> I.vcat |> I.hsnap ~align:`Left width 52 | in 53 | let create_image ~width ~prompt_f state = 54 | let prompt = 55 | let w = width / 2 in 56 | let image = I.(prompt_f () <|> string A.empty "> ") in 57 | if I.width image <= w then image 58 | else I.(string A.empty "..." <|> hsnap ~align:`Right (w - 3) image) 59 | in 60 | let image = state |> St.highlight highlighter |> I.hcat in 61 | I.(prompt <|> image), I.width prompt 62 | in 63 | let output image = 64 | Terminal.delete_line (); 65 | for _ = 1 to !image_height - 1 do 66 | Terminal.up (); 67 | Terminal.delete_line (); 68 | done; 69 | Notty_unix.output_image image; 70 | image_height := I.height image 71 | in 72 | let width = Terminal.width () in 73 | let image, offset = create_image ~width ~prompt_f state in 74 | wrap width image |> output; 75 | let pos = St.pos state + offset + 1 in 76 | Terminal.to_column pos; 77 | flush stdout; 78 | Lwt.return_unit 79 | 80 | let is_executing = ref false 81 | 82 | let perform_action action state = 83 | match action with 84 | | Execute -> 85 | (* TODO 86 | if not (St.input_is_terminated state) then state |> St.insert_uchar 0xA 87 | *) 88 | is_executing := true; 89 | image_height := 0; 90 | Notty_lwt.output_image_endline I.empty >>= fun () -> 91 | St.execute state ~print_error >>= fun (state, continue) -> 92 | Lwt_io.flush Lwt_io.stdout >|= fun () -> 93 | is_executing := false; 94 | (state, continue) 95 | | Apply f -> (f state, `Continue) |> Lwt.return 96 | | Complete -> 97 | (St.apply_predictions_longest_prefix state, `Continue) |> Lwt.return 98 | 99 | let rec handle_actions actions_stream ~prompt_f state = 100 | let open Lwt_stream in 101 | is_empty actions_stream >>= function 102 | | true -> Lwt.return_unit 103 | | false -> 104 | let rec aux state actions = 105 | match actions with 106 | | [] -> (state, `Continue) |> Lwt.return 107 | | action::actions -> 108 | state |> perform_action action >>= function 109 | | state, `Exit -> (state, `Exit) |> Lwt.return 110 | | state, `Continue -> aux state actions 111 | in 112 | actions_stream |> get_available |> aux state >>= function 113 | | _, `Exit -> Lwt.return_unit 114 | | state, `Continue -> 115 | state |> draw ~prompt_f >>= fun () -> 116 | state |> handle_actions actions_stream ~prompt_f 117 | 118 | let reset_f = ref None 119 | 120 | let reset () = 121 | match !reset_f with 122 | | None -> Lwt.return_unit 123 | | Some f -> reset_f := None; f () 124 | 125 | let () = Lwt_main.at_exit reset 126 | 127 | let action_for_event : Notty.Unescape.event -> action option = function 128 | | `Key (`Enter, []) -> Some (Execute) 129 | | `Key (`Uchar u, []) -> Some (Apply (St.insert_uchar u)) 130 | | `Key (`Backspace, []) -> Some (Apply St.backward_delete_uchar) 131 | | `Key (`Delete, []) -> Some (Apply St.forward_delete_uchar) 132 | | `Key (`Arrow `Up, []) -> Some (Apply St.history_up) 133 | | `Key (`Arrow `Down, []) -> Some (Apply St.history_down) 134 | | `Key (`Arrow `Left, []) -> Some (Apply St.move_left) 135 | | `Key (`Arrow `Right, []) -> Some (Apply St.move_right) 136 | | `Key (`Tab, []) -> Some (Complete) 137 | | `Key _ -> None 138 | | `Mouse _ -> None 139 | 140 | let create_action_stream () = 141 | let open Lwt_unix in 142 | (* Disabling canonical mode. *) 143 | tcgetattr stdin >>= fun tc -> 144 | reset_f := Some (fun () -> tcsetattr stdin TCSAFLUSH tc); 145 | let new_tc = {tc with c_icanon = false; c_echo = false} in 146 | tcsetattr stdin TCSAFLUSH new_tc >|= fun () -> 147 | (* Getting events from stdin. *) 148 | let filter = Unescape.create () in 149 | let buffer = Bytes.create 1024 in 150 | let rec get_event () = 151 | match Unescape.next filter with 152 | | `End -> Lwt.return_none 153 | | #Unescape.event as event -> 154 | if !is_executing then get_event () 155 | else Lwt.return_some event 156 | | `Await -> 157 | read stdin buffer 0 1024 >>= fun n -> 158 | Unescape.input filter buffer 0 n; 159 | get_event () 160 | in 161 | let rec get_action () = 162 | get_event () >>= function 163 | | None -> Lwt.return_none 164 | | Some event -> 165 | match action_for_event event with 166 | | None -> get_action () 167 | | Some action -> Lwt.return_some action 168 | in 169 | Lwt_stream.from get_action 170 | 171 | let run_lock = Lwt_mutex.create () 172 | 173 | let run ?prompt commands = 174 | Lwt_mutex.with_lock run_lock (fun () -> 175 | let prompt_f = 176 | match prompt with 177 | | None -> fun () -> I.empty 178 | | Some f -> f 179 | in 180 | create_action_stream () >>= fun actions -> 181 | let state = St.create commands in 182 | state |> draw ~prompt_f >>= fun () -> 183 | state |> handle_actions actions ~prompt_f >>= 184 | reset 185 | ) 186 | -------------------------------------------------------------------------------- /unix/shell_unix.mli: -------------------------------------------------------------------------------- 1 | 2 | val run : ?prompt:(unit -> Notty.image) -> Shell_commands.Map.t -> unit Lwt.t 3 | 4 | val print_error : string -> unit Lwt.t 5 | -------------------------------------------------------------------------------- /unix/shell_unix.mllib: -------------------------------------------------------------------------------- 1 | Shell_unix 2 | --------------------------------------------------------------------------------