├── .github ├── dependabot.yml └── workflows │ └── ci.yml ├── .gitignore ├── .ocamlformat ├── CHANGELOG.md ├── Makefile ├── README.md ├── demo ├── boiling.ml ├── demo.ml ├── demo_boiling.ml ├── demo_main.ml └── dune ├── docs ├── boiling.gif ├── newbase.gif └── tty.gif ├── dune ├── dune-project ├── ocli.opam ├── ppx_cross_match ├── cross.ml ├── cross_test.ml ├── dune └── ppx_cross_match.ml ├── qol ├── dune ├── qol.ml ├── qol_test.ml └── qol_unix.ml ├── rebase ├── dune ├── explode_commit.ml ├── explode_commit.mli ├── newbase.t │ ├── newbase │ └── run.t ├── rebase.ml ├── rebase_edit.ml ├── rebase_file_sample.txt ├── rebase_pass.ml ├── rebase_test.ml ├── rebase_test_inline.ml └── usage.md ├── tea ├── dune ├── tea.ml └── tea.mli ├── tools ├── changelog.ml ├── changelog.t │ ├── run.t │ └── test_changelog.md ├── dune ├── gitignorefmt.ml ├── gitignorefmt.t │ ├── run.t │ └── test.gitignore ├── sexpfmt.ml └── sexpfmt.t │ ├── run.t │ └── test_sexp └── tty ├── components.ml ├── components.mli ├── components_test.ml ├── components_test_inline.ml ├── dune ├── tty.ml ├── tty.mli ├── tty_test.ml └── tty_testing.ml /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | - package-ecosystem: "github-actions" 4 | directory: "/" 5 | schedule: 6 | # Check for updates to GitHub Actions every month 7 | interval: "monthly" -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | # Rename with 'name' input for manually triggered builds 3 | run-name: ${{ github.event.inputs.name }} 4 | 5 | on: 6 | # Triggers the workflow on push or pull request events 7 | push: 8 | branches: [ "*" ] 9 | pull_request: 10 | branches: [ "main" ] 11 | 12 | # Manual trigger for release 13 | workflow_dispatch: 14 | inputs: 15 | name: 16 | description: 'Release name' 17 | required: true 18 | default: 'snapshot' 19 | 20 | jobs: 21 | build: 22 | runs-on: ubuntu-latest 23 | steps: 24 | - uses: actions/checkout@v4 25 | 26 | - name: Set-up OCaml 27 | uses: ocaml/setup-ocaml@v3 28 | with: 29 | ocaml-compiler: 5.2 30 | 31 | - run: opam install . --deps-only --with-test 32 | 33 | - name: Enforce source code formatting 34 | run: | 35 | opam exec -- make fmt-check 36 | 37 | - name: Tests 38 | run: | 39 | opam exec -- make test 40 | 41 | - name: Build executables 42 | run: | 43 | opam exec -- make build 44 | opam exec -- make install-newbase INSTALL_ROOT=. 45 | 46 | - name: Generate changelog 47 | if: github.event_name == 'workflow_dispatch' 48 | run: | 49 | opam exec -- make changelog-for-release 50 | 51 | - name: Release 52 | # Only if manually triggered 53 | if: github.event_name == 'workflow_dispatch' 54 | uses: softprops/action-gh-release@v2 55 | with: 56 | name: ${{ github.event.inputs.name }} 57 | tag_name: ${{ github.event.inputs.name }} 58 | target_commitish: main 59 | body_path: CHANGELOG_FOR_RELEASE.md 60 | token: ${{ secrets.GITHUB_TOKEN }} 61 | files: | 62 | newbase 63 | rebase_edit 64 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Dune specifics 2 | _build 3 | _opam 4 | 5 | # VS Code specifics 6 | .vscode 7 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.7.1 2 | #### Bugfixes 3 | - Fixed commits' messages quoting that would stop rebase when exploding commits 4 | 5 | ## 0.7.0 6 | ### Rebase 7 | #### Features 8 | - Files can be individually 'exploded' (moved to a separate commit) from the file navigation tab by pressing **x**. Pressing **x** in the commit navigation view still toggle or untoggle all files. 9 | - Exploded commits can now also be renamed 10 | #### Changes 11 | - Switching between commit navigation and file navigation is now done with TAB key instead of **:f** command 12 | #### Bugfixes 13 | - Cursor is no longer blinking when editing a message or typing in CLI 14 | 15 | ## 0.6.0 16 | ### Rebase 17 | #### Features 18 | - Enter files navigation mode with the **:f** command. In this mode, modified files tab takes most of the available space and you can move up & down in the file list. This allow to browse the full list, that is cropped if containing too many files to fit the screen. 19 | ### tty 20 | - Column_divided component similar to Row_divided 21 | - Column_sliding component showing a portion of an entry array arround a given index 22 | 23 | ## 0.5.0 24 | ### Rebase 25 | #### Features 26 | - Cli and Renaming are now actual 'line edition modes' with cursor navigation. 27 | #### Bugfixes 28 | - `newbase` now restore a correct terminal state without needing to call `reset`. The `RESET` env argument is thus now ignored by `newbase`. 29 | ### tty 30 | - Introduced a (limited) component system to modularize individual widget rendering. Each component is responsible to create its own view within a box, and to reutrn the actual dimensions of this view. 31 | 32 | ## 0.4.0 33 | ### Rebase 34 | #### Features 35 | - Fixup: keep the fixuped commit message and discard of the previous commit message using **F** (uppercase) to fixup, translated to `fixup -C`. **f** (lowercase) still discards the fixuped commit message and keep the previous commit message. 36 | - Use prettier glyphs (▲▼∟ ...). Old glyphs can be toggled on with the **:raw** command, and toggled back to prettier glyphs with the **:pretty** command. 37 | - Display only relevant arrows (▲, ▼, or ▲▼) when moving a commit. 38 | - Add **:abort** command to discard all changes and exit the program. 39 | - Add **:inline** command to translate the current edition to actual git output. 40 | #### Changes 41 | - Exploded entries know keep the original message to improve readability of the exploded result 42 | ### ppx_cross_match 43 | - Better error messages embedded as error nodes instead of hard-failing 44 | 45 | ## 0.3.0 46 | ### Rebase 47 | #### Features 48 | - Introduced a 'vim like' command line. Triggered when typing **:** from either move or navigate mode. Typing **Esc** goes back to navigate mode, typing **Enter** execute the command. 49 | + The only command recognized for now is **:q** to quit the editor 50 | - Reduce rebase_edit binary size by ~4MB by extracting inline tests to a separate module 51 | - "Explode" split a commit into multiple ones, one for each file modified in the original commit 52 | - Rename with **r** or **R** instead of **Right -> Right**. **r** keeps the original message and let you edit it, **R** erase it to let you create a new one. 53 | #### Changes 54 | - Canceling a rename is now done with the **Esc** key instead of the **Left** arrow key 55 | - Quiting is now done by typing **:q** on the command line (see the *Features* section) 56 | - Rename is now done with the **r** or **R** keys in Move or Navigation mode (instead of **Right** from the navigation mode). 57 | #### Bugfixes 58 | - Fixup entries are now correctly indented even in 'Move' mode 59 | - Fixed entry list that would behave as a sliding window even when there is enough rows to display it fully 60 | 61 | ## 0.2.0 62 | ### Rebase 63 | #### Features 64 | - Allow to pass a number to newbase, this number will be interpreted as HEAD~number 65 | - Forbid fixuping the first rebase entry 66 | #### Bugfixes 67 | - Crop commit messages and file names to try to fit terminal width (live adapt to terminal resize) 68 | - Do not try to display more entries than available terminal rows, make a sliding window instead 69 | - Do not try to display more files than available terminal rows, trim modified files list instead 70 | 71 | ## 0.1.0 72 | ### Rebase 73 | #### Features 74 | - Display modified files along commits -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build default demo fmt test test-promote 2 | INSTALL_ROOT=~/bin 3 | 4 | default: fmt test build doc 5 | 6 | test: 7 | dune test 8 | 9 | test-promote: 10 | -dune test --auto-promote 11 | 12 | fmt: 13 | -dune fmt 14 | 15 | fmt-check: 16 | dune build @fmt 17 | 18 | build: 19 | dune build 20 | 21 | demo: 22 | dune exec demo_tty 23 | 24 | doc: 25 | dune build @doc 26 | dune build @doc-private 27 | 28 | install-newbase: build 29 | # Copy the executables into installation directory 30 | cp _build/install/default/bin/rebase_edit $(INSTALL_ROOT)/rebase_edit 31 | cp rebase/newbase.t/newbase $(INSTALL_ROOT)/newbase 32 | # Make the installed files writable to allow future deletion or replacement 33 | chmod +w $(INSTALL_ROOT)/rebase_edit 34 | chmod +w $(INSTALL_ROOT)/newbase 35 | 36 | changelog-for-release: 37 | dune exec changelog -- CHANGELOG.md CHANGELOG_FOR_RELEASE.md 38 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # OCaml CLI Mini-framework 2 | ![ci status badge](https://github.com/NyuB/ocli/actions/workflows/ci.yml/badge.svg) 3 | ![commits since last release](https://img.shields.io/github/commits-since/NyuB/ocli/latest/main) 4 | 5 | ## Apps 6 | ### Demos 7 | + [demo_tty](demo/demo_main.ml), a sample of all implemented ansi features and a quick way to visually check the behaviour of the framework on a given terminal. 8 | ![tty demo gif](docs/tty.gif) 9 | 10 | + [demo_boiling](demo/demo_boiling.ml), ongoing sandbox on ascii animation 11 | ![boiling demo gif](docs/boiling.gif) 12 | 13 | ### Newbase 14 | [rebase_edit](rebase/rebase_edit.ml), an interactive git rebase editor, and it's associated [newbase](rebase/newbase.t/newbase) script, intended as a drop-in replacement for `git rebase -i` 15 | ![rebase demo gif](docs/newbase.gif) 16 | You can browse the usage guide [here](rebase/usage.md) 17 | 18 | To get `rebase_edit` and `newbase`, you can [install them from source](#install-newbase-from-source) or get them from the [github release](https://github.com/NyuB/ocli/releases/latest/): 19 | 20 | ```console 21 | $ wget https://github.com/NyuB/ocli/releases/latest/download/newbase 22 | $ wget https://github.com/NyuB/ocli/releases/latest/download/rebase_edit 23 | $ chmod +x newbase rebase_edit 24 | $ # Supposing ~/bin is in your PATH, replace with the desired installation root 25 | $ mv newbase ~/bin/ 26 | $ mv rebase_edit ~/bin/ 27 | ``` 28 | 29 | 30 | ## Core libraries 31 | + [tea](tea/tea.mli), Elm-inspired application structure 32 | + [tty](tty/tty.mli) 33 | - Wrappers around OCaml Stdlib termios functions 34 | - Wrappers around ANSI terminal control sequences 35 | - [components](tty/components.mli), composable ansi widgets 36 | ## Miscelaneous 37 | + [ppx_cross_match](ppx_cross_match/ppx_cross_match.ml), a ppx to generate a sinle pattern from the cardinal_product of pattern tuples 38 | + [qol](qol/qol.ml) various quality-of-life helpers 39 | 40 | ## Development 41 | 42 | ### Requirements 43 | 44 | - Linux 45 | - opam 46 | - terminal with termios support 47 | 48 | ### Build 49 | 50 | ```bash 51 | opam install . --deps-only --with-test 52 | dune build 53 | ``` 54 | 55 | ### Run the tty demo 56 | 57 | ```bash 58 | make demo 59 | ``` 60 | 61 | **NB:** the demo includes indications to check if it is behaving correctly on your terminal 62 | 63 | ### Test suites 64 | Run the tests: 65 | ```bash 66 | make test 67 | ``` 68 | 69 | Update acceptance tests with the current outputs: 70 | 71 | ```bash 72 | make test-promote 73 | ``` 74 | 75 | ### Install newbase from source 76 | 77 | [rebase](rebase) provides two binaries: 78 | - [rebase_edit](rebase/rebase_edit.ml) is the interactive rebase editor, meant to be called by git with the rebase file. 79 | - [newbase](rebase/newbase.t/newbase) is a bash wrapper around `git rebase`. Its main purpose is to point git to rebase_edit as rebase editor along few other convenience features. 80 | 81 | ``` 82 | make install-newbase 83 | ``` 84 | 85 | Installation root can be chosen with the INSTALL_ROOT variable (defaults to `$HOME/bin`). `rebase_edit` and `newbase` will be placed at `${INSTALL_ROOT}/rebase_edit` and `${INSTALL_ROOT}/newbase` 86 | 87 | ``` 88 | make install-newbase INSTALL_ROOT=/somewhere/in/your/path 89 | ``` -------------------------------------------------------------------------------- /demo/boiling.ml: -------------------------------------------------------------------------------- 1 | type boiling_level = 2 | | No_Fire 3 | | One_Fire 4 | | Two_Fires 5 | | Three_Fires 6 | 7 | type t = 8 | { level : boiling_level 9 | ; tick : bool 10 | } 11 | 12 | let increase_level t = 13 | let level = 14 | match t.level with 15 | | No_Fire -> One_Fire 16 | | One_Fire -> Two_Fires 17 | | Two_Fires -> Three_Fires 18 | | Three_Fires -> Three_Fires 19 | in 20 | { t with level } 21 | ;; 22 | 23 | let decrease_level t = 24 | let level = 25 | match t.level with 26 | | No_Fire -> No_Fire 27 | | One_Fire -> No_Fire 28 | | Two_Fires -> One_Fire 29 | | Three_Fires -> Two_Fires 30 | in 31 | { t with level } 32 | ;; 33 | 34 | let tick t = { t with tick = not t.tick } 35 | 36 | let boiling_base = 37 | {||-----------| 38 | | |======== 39 | | | 40 | | | 41 | | | 42 | \___________/|} 43 | ;; 44 | 45 | let fire = {|\|/|} 46 | let no_fire = "" 47 | let fire_one = {| \|/ |} 48 | let fire_two = {| \|/ \|/ |} 49 | let fire_three = {| \|/ \|/ \|/ |} 50 | let no_smoke = "" 51 | 52 | let smoke_one = {| 53 | ( 54 | )|} 55 | 56 | let smoke_two = {| ) 57 | ( ( 58 | ) ) 59 | ( )|} 60 | 61 | let smoke_three = 62 | {| ( 63 | ) 64 | ) 65 | ( 66 | ( ) 67 | ) ) 68 | ( ) 69 | ) ) 70 | ( (|} 71 | ;; 72 | 73 | let reverse_smoke = function 74 | | '(' -> ')' 75 | | ')' -> '(' 76 | | c -> c 77 | ;; 78 | 79 | let smoke t s = String.map (if t.tick then reverse_smoke else Fun.id) s 80 | 81 | let lines s = 82 | if s = "" 83 | then [ "" ] 84 | else ( 85 | let rec aux acc current char_seq = 86 | match char_seq () with 87 | | Seq.Nil -> List.rev (current :: acc) 88 | | Seq.Cons ('\n', next) -> aux (current :: acc) "" next 89 | | Seq.Cons (c, next) -> aux acc (Printf.sprintf "%s%c" current c) next 90 | in 91 | aux [] "" (String.to_seq s)) 92 | ;; 93 | 94 | let array_of_line l = l |> String.to_seq |> Array.of_seq 95 | let array_of_lines lines = lines |> List.map array_of_line |> Array.of_list 96 | 97 | let lines_of_t t = 98 | match t.level with 99 | | No_Fire -> lines (smoke t no_smoke) @ lines boiling_base @ [ no_fire ] 100 | | One_Fire -> lines (smoke t smoke_one) @ lines boiling_base @ [ fire_one ] 101 | | Two_Fires -> lines (smoke t smoke_two) @ lines boiling_base @ [ fire_two ] 102 | | Three_Fires -> lines (smoke t smoke_three) @ lines boiling_base @ [ fire_three ] 103 | ;; 104 | 105 | module App : Tty.Ansi_App with type command = Tea.no_command = struct 106 | include Tty.Ansi_Tea_Base 107 | 108 | type command = Tea.no_command 109 | 110 | module S = Tty.Posix_style (struct 111 | let default_foreground_color = Tty.Default 112 | let default_background_color = Tty.Default 113 | end) 114 | 115 | type model = 116 | { boiling : t 117 | ; dim : Tty.position 118 | } 119 | 120 | let init = { boiling = { level = No_Fire; tick = false }; dim = { row = 1; col = 1 } } 121 | 122 | let view model = 123 | let base_row = 20 in 124 | if model.dim.row < base_row 125 | then 126 | Tty. 127 | [ { row = 1; col = 1 }, S.default_style, Text "Insufficient terminal dimensions" ] 128 | else 129 | List.rev (lines_of_t model.boiling) 130 | |> List.mapi (fun i l -> 131 | Tty.{ row = base_row - i; col = 1 }, S.default_style, Tty.Text l) 132 | ;; 133 | 134 | let update model msg = 135 | let open Tty in 136 | let next_model = 137 | match msg with 138 | | Size dim -> { model with dim } 139 | | Right | Left -> { model with boiling = tick model.boiling } 140 | | Char '+' -> { model with boiling = increase_level model.boiling } 141 | | Char '-' -> { model with boiling = decrease_level model.boiling } 142 | | _ -> model 143 | in 144 | next_model, [] 145 | ;; 146 | end 147 | 148 | module Tests = struct 149 | let print_lines l = l |> List.iter print_endline 150 | 151 | let%expect_test "No fire" = 152 | print_lines (lines_of_t { level = No_Fire; tick = false }); 153 | [%expect 154 | {| 155 | |-----------| 156 | | |======== 157 | | | 158 | | | 159 | | | 160 | \___________/|}] 161 | ;; 162 | 163 | let%expect_test "One fire" = 164 | print_lines (lines_of_t { level = One_Fire; tick = false }); 165 | [%expect 166 | {| 167 | ( 168 | ) 169 | |-----------| 170 | | |======== 171 | | | 172 | | | 173 | | | 174 | \___________/ 175 | \|/ |}] 176 | ;; 177 | 178 | let%expect_test _ = 179 | print_lines (lines_of_t { level = Two_Fires; tick = false }); 180 | [%expect 181 | {| 182 | ) 183 | ( ( 184 | ) ) 185 | ( ) 186 | |-----------| 187 | | |======== 188 | | | 189 | | | 190 | | | 191 | \___________/ 192 | \|/ \|/ |}] 193 | ;; 194 | 195 | let%expect_test _ = 196 | print_lines (lines_of_t { level = Three_Fires; tick = false }); 197 | print_endline "\n======== Next =======\n"; 198 | print_lines (lines_of_t { level = Three_Fires; tick = true }); 199 | [%expect 200 | {| 201 | ( 202 | ) 203 | ) 204 | ( 205 | ( ) 206 | ) ) 207 | ( ) 208 | ) ) 209 | ( ( 210 | |-----------| 211 | | |======== 212 | | | 213 | | | 214 | | | 215 | \___________/ 216 | \|/ \|/ \|/ 217 | 218 | ======== Next ======= 219 | 220 | ) 221 | ( 222 | ( 223 | ) 224 | ) ( 225 | ( ( 226 | ) ( 227 | ( ( 228 | ) ) 229 | |-----------| 230 | | |======== 231 | | | 232 | | | 233 | | | 234 | \___________/ 235 | \|/ \|/ \|/ |}] 236 | ;; 237 | end 238 | -------------------------------------------------------------------------------- /demo/demo.ml: -------------------------------------------------------------------------------- 1 | module Progress : sig 2 | type t 3 | 4 | val init : char -> t 5 | val is_full : t -> bool 6 | val is_empty : t -> bool 7 | val to_string : t -> string 8 | val handle_command : Tty.ansi_event -> t -> t 9 | end = struct 10 | type t = int * char 11 | 12 | let init c = 0, c 13 | let is_full (i, _) = i = 10 14 | let is_empty (i, _) = i = 0 15 | 16 | let to_string (i, c) = 17 | let left = String.make i c 18 | and right = String.make (10 - i) '_' in 19 | Printf.sprintf "[%s%s]" left right 20 | ;; 21 | 22 | let handle_command cmd (i, c) = 23 | let open Tty in 24 | let next_i = 25 | match cmd with 26 | | Left -> if i > 0 then i - 1 else 0 27 | | Right -> if i < 10 then i + 1 else 10 28 | | Del -> 0 29 | | _ -> i 30 | in 31 | next_i, c 32 | ;; 33 | 34 | module Tests = struct 35 | let progress_after t events = 36 | List.fold_left (fun acc i -> handle_command i acc) t events 37 | ;; 38 | 39 | let print_t t = print_endline (to_string t) 40 | let empty = init '@' 41 | let repeat n (event : Tty.ansi_event) = List.init n (fun _ -> event) 42 | 43 | let%expect_test "Empty" = 44 | print_t (progress_after empty []); 45 | [%expect {| [__________] |}] 46 | ;; 47 | 48 | let%expect_test "Right increment the bar" = 49 | let one_right = progress_after empty [ Right ] in 50 | print_t one_right; 51 | [%expect {| [@_________] |}]; 52 | let nine_more = progress_after one_right (repeat 9 Right) in 53 | print_t nine_more; 54 | [%expect {| [@@@@@@@@@@] |}] 55 | ;; 56 | 57 | let%expect_test "Left decrement the bar, del empty the bar" = 58 | let mid_fill = progress_after empty (repeat 5 Right) in 59 | print_t mid_fill; 60 | [%expect {| [@@@@@_____] |}]; 61 | let minus_one = progress_after mid_fill [ Left ] in 62 | print_t minus_one; 63 | [%expect {| [@@@@______] |}]; 64 | let deleted = progress_after minus_one [ Del ] in 65 | print_t deleted; 66 | [%expect {| [__________] |}] 67 | ;; 68 | end 69 | end 70 | 71 | module App : Tty.Ansi_App with type command = Tea.no_command = struct 72 | include Tty.Ansi_Tea_Base 73 | 74 | type command = Tea.no_command 75 | 76 | type phase = 77 | | Hello 78 | | Display_check 79 | | Progress_bar of Progress.t 80 | | End 81 | 82 | type model = Tty.position * phase 83 | 84 | let init = Tty.{ row = 1; col = 1 }, Hello 85 | 86 | let dimension_info_line ({ row; col } : Tty.position) = 87 | ( Tty.{ row; col = 1 } 88 | , Tty.Default_style.default_style 89 | , Tty.text @@ Printf.sprintf "(detected dimensions: %dx%d)" row col ) 90 | ;; 91 | 92 | let display_check_lines (pos : Tty.position) = 93 | dimension_info_line pos 94 | :: ([ ( Tty.Default_style.default_style 95 | , "The following lines surrounded by vvv and ^^^ are here to verify the \ 96 | terminal display has the expected behavior" ) 97 | ; Tty.Default_style.default_style, String.make 80 'v' 98 | ; ( { Tty.Default_style.default_style with fg_color = Some Red } 99 | , "This should appear Red" ) 100 | ; ( { Tty.Default_style.default_style with fg_color = Some Green } 101 | , "This should appear Green" ) 102 | ; ( { Tty.Default_style.default_style with fg_color = Some Blue } 103 | , "This should appear Blue" ) 104 | ; ( { Tty.Default_style.default_style with fg_color = Some Yellow } 105 | , "This should appear Yellow" ) 106 | ; ( { Tty.Default_style.default_style with fg_color = Some Magenta } 107 | , "This should appear Magenta" ) 108 | ; ( { Tty.Default_style.default_style with fg_color = Some Cyan } 109 | , "This should appear Cyan" ) 110 | ; ( { Tty.Default_style.default_style with bg_color = Some Red } 111 | , "This should appear Red" ) 112 | ; ( { Tty.Default_style.default_style with bg_color = Some Green } 113 | , "This should appear Green" ) 114 | ; ( { Tty.Default_style.default_style with bg_color = Some Blue } 115 | , "This should appear Blue" ) 116 | ; ( { Tty.Default_style.default_style with bg_color = Some Yellow } 117 | , "This should appear Yellow" ) 118 | ; ( { Tty.Default_style.default_style with bg_color = Some Magenta } 119 | , "This should appear Magenta" ) 120 | ; ( { Tty.Default_style.default_style with bg_color = Some Cyan } 121 | , "This should appear Cyan" ) 122 | ; ( { Tty.Default_style.default_style with underlined = true } 123 | , "This should be underlined" ) 124 | ; ( { Tty.Default_style.default_style with striked = true } 125 | , "This should be striked out" ) 126 | ; { Tty.Default_style.default_style with bold = true }, "This should be bold" 127 | ; ( { Tty.Default_style.default_style with underlined = true; bold = true } 128 | , "This should be bold and underlined" ) 129 | ; ( { bg_color = Some Yellow 130 | ; fg_color = None 131 | ; underlined = true 132 | ; bold = false 133 | ; striked = false 134 | } 135 | , "This should be yellow and underlined" ) 136 | ; Tty.Default_style.default_style, String.make 80 '^' 137 | ; ( Tty.Default_style.default_style 138 | , "Press Enter to proceed to the next phase of the demo" ) 139 | ] 140 | |> List.mapi (fun i (s, str) -> Tty.{ row = i + 1; col = 1 }, s, Tty.text str)) 141 | ;; 142 | 143 | let simply_lines lines = 144 | List.mapi 145 | (fun i l -> 146 | Tty.{ row = i + 1; col = 1 }, Tty.Default_style.default_style, Tty.text l) 147 | lines 148 | ;; 149 | 150 | let hello = 151 | [ " ##### ####" 152 | ; " ######## ###### #####" 153 | ; " ######### ####### # #" 154 | ; " # # # # # o ##" 155 | ; " # Hell'O # # Caml # # ###" 156 | ; " ## # ##### #####" 157 | ; " # This is a demo/test program #" 158 | ; " ## ##" 159 | ; " # Press Enter to proceed ##" 160 | ; " # ####" 161 | ; " /###########################" 162 | ; " / #### # ##" 163 | ; " | ## # # #" 164 | ; " / ## # # #" 165 | ; "* ## ## # ##" 166 | ; " ## # ## ##" 167 | ; " ## # # #" 168 | ; " # ## ## ##" 169 | ] 170 | ;; 171 | 172 | let progress_bar_lines pos bar = 173 | dimension_info_line pos 174 | :: simply_lines 175 | [ "Now testing the terminal I/O interactivity behavior" 176 | ; "A progress bar will appear. You can:" 177 | ; (if not @@ Progress.is_full bar 178 | then "\t\xE2\x87\x92 increase it by pressing the right arrow key," 179 | else "") 180 | ; (if not @@ Progress.is_empty bar 181 | then "\t\xE2\x87\x90 decrease it by pressing the left arrow key," 182 | else "") 183 | ; (if not @@ Progress.is_empty bar 184 | then "\tDEL clear it by pressing the delete key," 185 | else "") 186 | ; "Press Enter to proceed to the next phase of the demo" 187 | ; Progress.to_string bar 188 | ] 189 | ;; 190 | 191 | let view (pos, model) = 192 | match model with 193 | | Hello -> simply_lines hello 194 | | Display_check -> display_check_lines pos 195 | | Progress_bar b -> progress_bar_lines pos b 196 | | End -> simply_lines [ "End of Demo, hit Ctrl+C to exit he program" ] 197 | ;; 198 | 199 | let update (pos, model) message = 200 | let next_model = 201 | match model, message with 202 | | m, Tty.Size p -> p, m 203 | | Hello, Tty.Enter -> pos, Display_check 204 | | Display_check, Tty.Enter -> pos, Progress_bar (Progress.init '@') 205 | | Progress_bar _, Tty.Enter -> pos, End 206 | | Progress_bar b, msg -> pos, Progress_bar (Progress.handle_command msg b) 207 | | m, _ -> pos, m 208 | in 209 | next_model, [] 210 | ;; 211 | 212 | module Tests = struct 213 | let repr_state = function 214 | | Hello -> "Hello" 215 | | Display_check -> "Display Check" 216 | | Progress_bar b -> Printf.sprintf "Progress Bar %s" (Progress.to_string b) 217 | | End -> "End" 218 | ;; 219 | 220 | let repr_model ({ row; col } : Tty.position) m = 221 | Printf.sprintf "(%dx%d) %s" row col (repr_state m) 222 | ;; 223 | 224 | let print_t (pos, m) = print_endline (repr_model pos m) 225 | 226 | let play_events model events = 227 | List.fold_left (fun m e -> Qol.first @@ update m e) model events 228 | ;; 229 | 230 | let%expect_test "Hello then Display check then Progress bar then End" = 231 | let enter m = play_events m [ Enter ] in 232 | let m = init in 233 | print_t m; 234 | [%expect {| (1x1) Hello |}]; 235 | let m = enter m in 236 | print_t m; 237 | [%expect {| (1x1) Display Check |}]; 238 | let m = enter m in 239 | print_t m; 240 | [%expect {| (1x1) Progress Bar [__________] |}]; 241 | let m = enter m in 242 | print_t m; 243 | [%expect {| (1x1) End |}] 244 | ;; 245 | 246 | let%expect_test "Update size" = 247 | let resized = play_events init [ Size { row = 50; col = 80 } ] in 248 | print_t resized; 249 | [%expect {| (50x80) Hello |}] 250 | ;; 251 | 252 | let%expect_test "Update progress bar" = 253 | let progress = 254 | play_events 255 | init 256 | [ Size { row = 50; col = 80 }; Enter; Enter; Right; Right; Right ] 257 | in 258 | print_t progress; 259 | [%expect {| (50x80) Progress Bar [@@@_______] |}]; 260 | let progress = play_events progress [ Left ] in 261 | print_t progress; 262 | [%expect {| (50x80) Progress Bar [@@________] |}]; 263 | let progress = play_events progress [ Del ] in 264 | print_t progress; 265 | [%expect {| (50x80) Progress Bar [__________] |}] 266 | ;; 267 | end 268 | end 269 | -------------------------------------------------------------------------------- /demo/demo_boiling.ml: -------------------------------------------------------------------------------- 1 | open Qol 2 | 3 | let () = 4 | let module Terminal = struct 5 | let terminal_in = Unix.stdin 6 | let terminal_out = Out_channel.stdout 7 | 8 | module Style = Tty.Default_style 9 | end 10 | in 11 | let module Terminal_platform = Tty.Posix_terminal_platform (Terminal) in 12 | Tea.loop_app (module Boiling.App) (module Terminal_platform) 13 | ;; 14 | -------------------------------------------------------------------------------- /demo/demo_main.ml: -------------------------------------------------------------------------------- 1 | open Qol 2 | 3 | let () = 4 | let module Terminal = struct 5 | let terminal_in = Unix.stdin 6 | let terminal_out = Out_channel.stdout 7 | 8 | module Style = Tty.Default_style 9 | end 10 | in 11 | let module Terminal_platform = Tty.Posix_terminal_platform (Terminal) in 12 | Tea.loop_app (module Demo.App) (module Terminal_platform) 13 | ;; 14 | -------------------------------------------------------------------------------- /demo/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name demo) 3 | (modules demo) 4 | (libraries qol tty) 5 | (inline_tests) 6 | (preprocess 7 | (pps ppx_expect))) 8 | 9 | (executable 10 | (public_name demo_tty) 11 | (name demo_main) 12 | (modules demo_main) 13 | (libraries demo qol tty unix)) 14 | 15 | (library 16 | (name boiling) 17 | (modules boiling) 18 | (libraries tty) 19 | (inline_tests) 20 | (preprocess 21 | (pps ppx_expect))) 22 | 23 | (executable 24 | (public_name demo_boiling) 25 | (name demo_boiling) 26 | (modules demo_boiling) 27 | (libraries boiling qol tty unix)) 28 | -------------------------------------------------------------------------------- /docs/boiling.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NyuB/ocli/7780449d057993cef6582e3d71ffce4531fe90ea/docs/boiling.gif -------------------------------------------------------------------------------- /docs/newbase.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NyuB/ocli/7780449d057993cef6582e3d71ffce4531fe90ea/docs/newbase.gif -------------------------------------------------------------------------------- /docs/tty.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/NyuB/ocli/7780449d057993cef6582e3d71ffce4531fe90ea/docs/tty.gif -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (target dune-project.formatted) 3 | (action 4 | (run %{dep:tools/sexpfmt.exe} %{dep:dune-project} dune-project.formatted))) 5 | 6 | (rule 7 | (alias fmt) 8 | (action 9 | (diff dune-project dune-project.formatted))) 10 | 11 | (rule 12 | (target .gitignore.formatted) 13 | (action 14 | (run %{dep:tools/gitignorefmt.exe} %{dep:.gitignore} .gitignore.formatted))) 15 | 16 | (rule 17 | (alias fmt) 18 | (action 19 | (diff .gitignore .gitignore.formatted))) 20 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.11) 2 | (name ocli) 3 | (generate_opam_files true) 4 | (source (github NyuB/ocli)) 5 | (authors "Brice Decaestecker") 6 | (maintainers "Brice Decaestecker") 7 | (license OPEN_BAR_YO) 8 | (documentation https://github.com/NyuB/ocli) 9 | (package (name ocli) (synopsis "OCaml terminal interaction demo") 10 | (description 11 | "Minimal skeleton for terminal interaction using termios and terminal control sequences") 12 | (depends (ocaml (>= 5.0)) dune (alcotest :with-test) 13 | (ocamlformat :with-test) (ppx_expect :with-test) (sexplib :with-test)) 14 | (tags (cli termios tty))) -------------------------------------------------------------------------------- /ocli.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "OCaml terminal interaction demo" 4 | description: 5 | "Minimal skeleton for terminal interaction using termios and terminal control sequences" 6 | maintainer: ["Brice Decaestecker"] 7 | authors: ["Brice Decaestecker"] 8 | license: "OPEN_BAR_YO" 9 | tags: ["cli" "termios" "tty"] 10 | homepage: "https://github.com/NyuB/ocli" 11 | doc: "https://github.com/NyuB/ocli" 12 | bug-reports: "https://github.com/NyuB/ocli/issues" 13 | depends: [ 14 | "ocaml" {>= "5.0"} 15 | "dune" {>= "3.11"} 16 | "alcotest" {with-test} 17 | "ocamlformat" {with-test} 18 | "ppx_expect" {with-test} 19 | "sexplib" {with-test} 20 | "odoc" {with-doc} 21 | ] 22 | build: [ 23 | ["dune" "subst"] {dev} 24 | [ 25 | "dune" 26 | "build" 27 | "-p" 28 | name 29 | "-j" 30 | jobs 31 | "@install" 32 | "@runtest" {with-test} 33 | "@doc" {with-doc} 34 | ] 35 | ] 36 | dev-repo: "git+https://github.com/NyuB/ocli.git" 37 | -------------------------------------------------------------------------------- /ppx_cross_match/cross.ml: -------------------------------------------------------------------------------- 1 | (** [cross left right] is a list with one entry for each element of [right] corresponding to this element appended to [left] *) 2 | let cross (left : 'a list) (right : 'a list) : 'a list list = 3 | let left_rev = List.rev left in 4 | List.map (fun b -> List.rev (b :: left_rev)) right 5 | ;; 6 | -------------------------------------------------------------------------------- /ppx_cross_match/cross_test.ml: -------------------------------------------------------------------------------- 1 | let quick_test (name, test) = name, `Quick, test 2 | let quick_tests tests = List.map quick_test tests 3 | 4 | let test_0x2 = 5 | ( "0x2" 6 | , fun () -> 7 | Alcotest.check 8 | (Alcotest.list (Alcotest.list Alcotest.int)) 9 | "Ok" 10 | [ [ 1 ]; [ 2 ] ] 11 | (Cross.cross [] [ 1; 2 ]) ) 12 | ;; 13 | 14 | let test_1x2 = 15 | ( "1x2" 16 | , fun () -> 17 | Alcotest.check 18 | (Alcotest.list (Alcotest.list Alcotest.int)) 19 | "Ok" 20 | [ [ 1; 2 ]; [ 1; 3 ] ] 21 | (Cross.cross [ 1 ] [ 2; 3 ]) ) 22 | ;; 23 | 24 | let test_2x1 = 25 | ( "2x1" 26 | , fun () -> 27 | Alcotest.check 28 | (Alcotest.list (Alcotest.list Alcotest.int)) 29 | "Ok" 30 | [ [ 1; 2; 3 ] ] 31 | (Cross.cross [ 1; 2 ] [ 3 ]) ) 32 | ;; 33 | 34 | let match_with_cross a b = 35 | match a, b with 36 | | [%cross_match ("A", "B"), (Some 1, Some 2, Some 3)] -> true 37 | | _ -> false 38 | ;; 39 | 40 | let match_with_cross_any a b = 41 | match a, b with 42 | | [%cross_match ("A", "B"), Some [%cross_any]] -> true 43 | | _ -> false 44 | ;; 45 | 46 | let match_with_cross_nested_tuples a b = 47 | match a, b with 48 | | [%cross_match (("A", 1), ("B", 2)), ('a', 'b')] -> true 49 | | _ -> false 50 | ;; 51 | 52 | let match_with_cross_nested_constructor a b = 53 | match a, b with 54 | | [%cross_match (Some (Some 1), Some (Some 2)), ('a', 'b')] -> true 55 | | _ -> false 56 | ;; 57 | 58 | let match_with_cross_list a b = 59 | match a, b with 60 | | [%cross_match ([], [ 1 ], [ 1; 2 ]), ('a', 'b')] -> true 61 | | _ -> false 62 | ;; 63 | 64 | type abc = 65 | | A of bool 66 | | B of bool 67 | | C 68 | 69 | let match_with_cross_bind a b = 70 | match a, b with 71 | | [%cross_match (A t, B t), [%cross_any]] -> t 72 | | C, _ -> false 73 | ;; 74 | 75 | let do_match f a b = 76 | "Match", fun () -> Alcotest.check Alcotest.bool "Expected a match" true (f a b) 77 | ;; 78 | 79 | let do_not_match f a b = 80 | "No Match", fun () -> Alcotest.check Alcotest.bool "Expected no match" false (f a b) 81 | ;; 82 | 83 | let () = 84 | Alcotest.run 85 | "Cross products" 86 | [ "Cross", quick_tests [ test_0x2; test_1x2; test_2x1 ] 87 | ; ( "Cross match with constant" 88 | , let do_match = do_match match_with_cross 89 | and do_not_match = do_not_match match_with_cross in 90 | quick_tests 91 | [ do_match "A" (Some 1) 92 | ; do_match "B" (Some 1) 93 | ; do_match "A" (Some 2) 94 | ; do_match "B" (Some 2) 95 | ; do_match "A" (Some 3) 96 | ; do_match "B" (Some 3) 97 | ; do_not_match "A" None 98 | ; do_not_match "B" None 99 | ; do_not_match "A" (Some 4) 100 | ; do_not_match "C" (Some 1) 101 | ] ) 102 | ; ( "Cross match with any" 103 | , let do_match = do_match match_with_cross_any 104 | and do_not_match = do_not_match match_with_cross_any in 105 | quick_tests 106 | [ do_match "A" (Some 3); do_match "A" (Some 1); do_not_match "C" (Some 1) ] ) 107 | ; ( "Cross match with nested tuples" 108 | , let do_match = do_match match_with_cross_nested_tuples 109 | and do_not_match = do_not_match match_with_cross_nested_tuples in 110 | quick_tests [ do_match ("A", 1) 'a'; do_not_match ("A", 5) '1' ] ) 111 | ; ( "Cross match with nested constructors" 112 | , let do_match = do_match match_with_cross_nested_constructor 113 | and do_not_match = do_not_match match_with_cross_nested_constructor in 114 | quick_tests [ do_match (Some (Some 2)) 'a'; do_not_match None 'a' ] ) 115 | ; ( "Cross match with lists" 116 | , let do_match = do_match match_with_cross_list 117 | and do_not_match = do_not_match match_with_cross_list in 118 | quick_tests 119 | [ do_match [] 'a' 120 | ; do_match [ 1 ] 'a' 121 | ; do_match [ 1; 2 ] 'a' 122 | ; do_not_match [ 5 ] 'a' 123 | ] ) 124 | ; ( "Cross match with binds" 125 | , let do_match = do_match match_with_cross_bind 126 | and do_not_match = do_not_match match_with_cross_bind in 127 | quick_tests 128 | [ do_match (A true) 0 129 | ; do_match (B true) 0 130 | ; do_not_match (A false) 0 131 | ; do_not_match (B false) 0 132 | ; do_not_match C 0 133 | ] ) 134 | ] 135 | ;; 136 | -------------------------------------------------------------------------------- /ppx_cross_match/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_cross_match) 3 | (modules ppx_cross_match) 4 | (kind ppx_rewriter) 5 | (libraries cross ppxlib)) 6 | 7 | (tests 8 | (names cross_test) 9 | (modules cross_test) 10 | (libraries alcotest cross) 11 | (preprocess 12 | (pps ppx_cross_match))) 13 | 14 | (library 15 | (name cross) 16 | (modules cross)) 17 | -------------------------------------------------------------------------------- /ppx_cross_match/ppx_cross_match.ml: -------------------------------------------------------------------------------- 1 | (** Ppx rewriter to expand tuple of patterns to a pattern matching all combinations of these patterns 2 | E.g: ( (A,B), (1,2) ) would generate (A, 1) | (A, 2) | (B, 1) | (B, 2) -> ... *) 3 | 4 | open Ppxlib 5 | 6 | let combine_patterns ~loc patterns = 7 | let first, rest = List.hd patterns, List.tl patterns in 8 | List.fold_left (Ast_builder.Default.ppat_or ~loc) first rest 9 | ;; 10 | 11 | let variant_pat_of_construct_expr ~loc pat_of_expr label = 12 | let open Ast_builder.Default in 13 | function 14 | | Some { pexp_desc = Pexp_constant c; pexp_loc = eloc; _ } -> 15 | ppat_construct ~loc label (Some (ppat_constant ~loc:eloc c)) 16 | | Some e -> ppat_construct ~loc label (Some (pat_of_expr e)) 17 | | None -> ppat_construct ~loc label None 18 | ;; 19 | 20 | let allowed_error_message = 21 | "Only constants, identifiers, constructor applications, tuples and '[%%cross_any]' \ 22 | extension nodes are allowed" 23 | ;; 24 | 25 | let rec pattern_of_expr (e : expression) : pattern = 26 | let open Ast_builder.Default in 27 | let loc = e.pexp_loc in 28 | match e.pexp_desc with 29 | | Pexp_constant c -> ppat_constant ~loc c 30 | | Pexp_extension (e, _) when e.txt = "cross_any" -> ppat_any ~loc 31 | | Pexp_ident { loc = id_loc; txt = Lident id } -> 32 | ppat_var ~loc { loc = id_loc; txt = id } 33 | | Pexp_construct (label, e) -> 34 | variant_pat_of_construct_expr ~loc pattern_of_expr label e 35 | | Pexp_tuple es -> ppat_tuple ~loc (List.map pattern_of_expr es) 36 | | Pexp_record _ -> 37 | ppat_extension 38 | ~loc 39 | (Location.error_extensionf 40 | ~loc 41 | "Record are not allowed within a cross_match pattern. %s" 42 | allowed_error_message) 43 | | Pexp_constraint _ -> 44 | ppat_extension 45 | ~loc 46 | (Location.error_extensionf 47 | ~loc 48 | "Module expression are not allowed within a cross_match pattern. %s" 49 | allowed_error_message) 50 | | Pexp_extension (e, _) -> 51 | ppat_extension 52 | ~loc 53 | (Location.error_extensionf 54 | ~loc 55 | "Extension nodes [%%%s] are not allowed within a cross_match pattern. %s" 56 | e.txt 57 | allowed_error_message) 58 | | _ -> 59 | ppat_extension 60 | ~loc 61 | (Location.error_extensionf 62 | ~loc 63 | "Invalid cross_match pattern. %s" 64 | allowed_error_message) 65 | ;; 66 | 67 | let patterns_of_expr (e : expression) = 68 | match e.pexp_desc with 69 | | Pexp_tuple es -> List.map pattern_of_expr es 70 | | _ -> [ pattern_of_expr e ] 71 | ;; 72 | 73 | let expand ~ctxt (exprs : expression list) _ = 74 | let loc = Expansion_context.Extension.extension_point_loc ctxt in 75 | let patterns_set = List.map patterns_of_expr exprs in 76 | let crossed = 77 | List.fold_left 78 | (fun all pats -> List.concat_map (fun a -> Cross.cross a pats) all) 79 | [ [] ] 80 | patterns_set 81 | in 82 | let all = List.map (Ast_builder.Default.ppat_tuple ~loc) crossed in 83 | combine_patterns ~loc all 84 | ;; 85 | 86 | let matcher = 87 | let open Ast_pattern in 88 | pstr (pstr_eval (pexp_tuple __) __ ^:: nil) 89 | ;; 90 | 91 | let cross_match_extender = Extension.V3.declare "cross_match" Pattern matcher expand 92 | let extender_rule = Context_free.Rule.extension cross_match_extender 93 | let () = Driver.register_transformation ~rules:[ extender_rule ] "cross_match" 94 | -------------------------------------------------------------------------------- /qol/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name qol) 3 | (modules qol)) 4 | 5 | (library 6 | (name qol_unix) 7 | (modules qol_unix) 8 | (libraries unix)) 9 | 10 | (tests 11 | (names qol_test) 12 | (modules qol_test) 13 | (libraries alcotest qol)) 14 | -------------------------------------------------------------------------------- /qol/qol.ml: -------------------------------------------------------------------------------- 1 | module List : sig 2 | include module type of List 3 | 4 | (** [not_none l] is the list of non-none elements of [l] *) 5 | val not_none : 'a option list -> 'a list 6 | 7 | (** [sublist from l] is the sub-list of [l] starting at index [from]. If [from >= List.length l] then result is empty. If [from <= 0] then result is [l] *) 8 | val sublist : int -> 'a list -> 'a list 9 | 10 | (** [at_most n l] is the [n] first elements of [l]. If [l] has less than [n] elements, the result is [l]. If [n <= 0] result is the empty list *) 11 | val at_most : int -> 'a list -> 'a list 12 | 13 | val singleton : 'a -> 'a list 14 | end = struct 15 | include List 16 | 17 | let not_none l = List.filter_map Fun.id l 18 | 19 | let rec sublist (from : int) (l : 'a list) : 'a list = 20 | match from, l with 21 | | over, res when over <= 0 -> res 22 | | _, [] -> [] 23 | | pos, _ :: t -> sublist (pos - 1) t 24 | ;; 25 | 26 | let at_most n l = 27 | let rec aux acc n = function 28 | | [] -> List.rev acc 29 | | h :: t -> if n > 0 then aux (h :: acc) (n - 1) t else List.rev acc 30 | in 31 | aux [] n l 32 | ;; 33 | 34 | let singleton a = [ a ] 35 | end 36 | 37 | module Out_channel : sig 38 | include module type of Out_channel 39 | 40 | val output_line : t -> string -> unit 41 | end = struct 42 | include Out_channel 43 | 44 | let output_line o s = 45 | output_string o s; 46 | output_char o '\n' 47 | ;; 48 | end 49 | 50 | let first (a, _) = a 51 | 52 | let ( |?? ) opt lazy_default = 53 | match opt with 54 | | None -> Lazy.force lazy_default 55 | | Some v -> v 56 | ;; 57 | 58 | let ( |?: ) opt default = Option.value ~default opt 59 | let ( |? ) f opt = Option.map opt f 60 | let ( |?* ) f opt = Option.bind f opt 61 | -------------------------------------------------------------------------------- /qol/qol_test.ml: -------------------------------------------------------------------------------- 1 | open Qol 2 | 3 | let check_empty_list (testable : 'a Alcotest.testable) (actual : 'a list) = 4 | Alcotest.check (Alcotest.list testable) "Expected empty list" [] actual 5 | ;; 6 | 7 | let not_none_empty = 8 | ( "not_none on empty list is identity" 9 | , fun () -> Alcotest.(check (list unit)) "Expected empty list" [] (List.not_none []) ) 10 | ;; 11 | 12 | let not_none_only_none = 13 | ( "not_none on only None is empty list" 14 | , fun () -> check_empty_list Alcotest.unit (List.not_none [ None; None; None ]) ) 15 | ;; 16 | 17 | let not_none_order = 18 | ( "not_none preserves original list order" 19 | , fun () -> 20 | Alcotest.(check (list int)) 21 | "Expected list in same order" 22 | [ 1; 2; 3 ] 23 | (List.not_none [ None; Some 1; Some 2; None; Some 3 ]) ) 24 | ;; 25 | 26 | let sublist_empty = 27 | ( "sub list of an empty list is empty" 28 | , fun () -> 29 | List.iter 30 | (fun n -> check_empty_list Alcotest.int (List.sublist n [])) 31 | [ 0; 1; 2; 3; 4; 5 ] ) 32 | ;; 33 | 34 | let check_sublist tag expected n l = 35 | ( tag 36 | , fun () -> 37 | Alcotest.check 38 | (Alcotest.list Alcotest.int) 39 | "Sublist does not match expected" 40 | expected 41 | (List.sublist n l) ) 42 | ;; 43 | 44 | let check_at_most tag expected n l = 45 | ( tag 46 | , fun () -> 47 | Alcotest.check 48 | (Alcotest.list Alcotest.int) 49 | "Sublist does not match expected" 50 | expected 51 | (List.at_most n l) ) 52 | ;; 53 | 54 | let opt_default_none = 55 | ( "use default if None" 56 | , fun () -> 57 | let default = "Default" in 58 | let actual = None |?? lazy default in 59 | Alcotest.(check string) "Expected default to be used" default actual ) 60 | ;; 61 | 62 | let opt_default_laziness = 63 | ( "do not force default if Some" 64 | , fun () -> 65 | let updated = ref false in 66 | let () = Some () |?? lazy (updated := true) in 67 | Alcotest.(check bool) "Expected updated not to have been executed" false !updated ) 68 | ;; 69 | 70 | let quick_test (name, test) = name, `Quick, test 71 | let quick_tests tests = List.map quick_test tests 72 | 73 | let () = 74 | Alcotest.run 75 | "Quality Of Life functions" 76 | [ "List.not_none", quick_tests [ not_none_empty; not_none_order; not_none_only_none ] 77 | ; ( "List.sublist" 78 | , quick_tests 79 | [ sublist_empty 80 | ; check_sublist "sub list within bound" [ 2; 3 ] 1 [ 1; 2; 3 ] 81 | ; check_sublist "sub list beyond bound" [] 3 [ 1; 2 ] 82 | ; check_sublist "sub list 0 equal list" [ 1; 2 ] 0 [ 1; 2 ] 83 | ] ) 84 | ; ( "List.at_most" 85 | , quick_tests 86 | [ check_at_most "at most on empty list" [] 1 [] 87 | ; check_at_most "at most length" [ 1; 2; 3 ] 3 [ 1; 2; 3 ] 88 | ; check_at_most "at most more than length" [ 1; 2 ] 5 [ 1; 2 ] 89 | ; check_at_most "at most less than length" [ 1; 2 ] 2 [ 1; 2; 3 ] 90 | ] ) 91 | ; "Option operators", quick_tests [ opt_default_none; opt_default_laziness ] 92 | ] 93 | ;; 94 | -------------------------------------------------------------------------------- /qol/qol_unix.ml: -------------------------------------------------------------------------------- 1 | (** [command "prog" [|"a"; "b"|]] executes 'prog a b' and returns its standard output *) 2 | let command program args = 3 | let out, process_in, err = 4 | Unix.open_process_args_full program (Array.concat [ [| program |]; args ]) [||] 5 | in 6 | let rec aux acc = 7 | try 8 | let line = input_line out in 9 | aux (line :: acc) 10 | with 11 | | End_of_file -> List.rev acc 12 | in 13 | Fun.protect ~finally:(fun () -> 14 | ignore @@ Unix.close_process_full (out, process_in, err)) 15 | @@ fun () -> aux [] 16 | ;; 17 | -------------------------------------------------------------------------------- /rebase/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name rebase) 3 | (modules rebase explode_commit) 4 | (libraries components qol tea tty) 5 | (preprocess 6 | (pps ppx_cross_match))) 7 | 8 | (library 9 | (name rebase_test_inline) 10 | (modules rebase_test_inline) 11 | (libraries qol rebase tea tty tty_testing) 12 | (inline_tests) 13 | (preprocess 14 | (pps ppx_expect))) 15 | 16 | (executable 17 | (public_name rebase_edit) 18 | (name rebase_edit) 19 | (modules rebase_edit) 20 | (libraries qol_unix tea tty rebase)) 21 | 22 | (tests 23 | (names rebase_test) 24 | (modules rebase_test) 25 | (libraries qol rebase alcotest) 26 | (deps rebase_file_sample.txt)) 27 | 28 | (executable 29 | (public_name rebase_pass) 30 | (name rebase_pass) 31 | (modules rebase_pass) 32 | (libraries)) 33 | 34 | (cram 35 | (deps %{bin:rebase_pass})) 36 | -------------------------------------------------------------------------------- /rebase/explode_commit.ml: -------------------------------------------------------------------------------- 1 | module StringSet = Set.Make (String) 2 | 3 | type t = StringSet.t 4 | 5 | let init_nothing : t = StringSet.empty 6 | let init_all l : t = StringSet.of_list l 7 | let nothing_exploded (exploded : t) : bool = StringSet.is_empty exploded 8 | let is_exploded (exploded : t) (file : string) : bool = StringSet.mem file exploded 9 | 10 | let kept_exploded all (exploded : t) = 11 | let kept = StringSet.diff (StringSet.of_list all) exploded in 12 | StringSet.to_list kept, StringSet.to_list exploded 13 | ;; 14 | 15 | let toggle (exploded : t) (file : string) : t = 16 | if StringSet.mem file exploded 17 | then StringSet.remove file exploded 18 | else StringSet.add file exploded 19 | ;; 20 | 21 | let toggle_i all (exploded : t) (i : int) : t = 22 | match List.nth_opt all i with 23 | | None -> exploded 24 | | Some file -> toggle exploded file 25 | ;; 26 | 27 | let exploded_list t = StringSet.to_list t 28 | -------------------------------------------------------------------------------- /rebase/explode_commit.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val init_nothing : t 4 | val init_all : string list -> t 5 | val nothing_exploded : t -> bool 6 | val is_exploded : t -> string -> bool 7 | 8 | (** [kept_exploded all_modified t] returns two sets: 9 | - the first set is the modified files that are to be kept in the original commit 10 | - the second set is the modifed files that are to be commited separately *) 11 | val kept_exploded : string list -> t -> string list * string list 12 | 13 | (** [toggle exploded file] removes (if present) or add (if absent) [file] from/to the [exploded] set *) 14 | val toggle : t -> string -> t 15 | 16 | (** [toggle_i all exploded index] is the same as [toggle exploded file] where file is the file at [index] in [all]. 17 | 18 | Return [exploded] as is if [index] is not a valid index within [all]*) 19 | val toggle_i : string list -> t -> int -> t 20 | 21 | val exploded_list : t -> string list 22 | -------------------------------------------------------------------------------- /rebase/newbase.t/newbase: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | REF=${1:?"Usage: newbase "} 4 | CUSTOM_EDITOR=${CUSTOM_EDITOR:-rebase_edit} 5 | 6 | # If the first argument is a number, interpret it as an offset from the current HEAD 7 | ONLY_DIGITS="^[0-9]+$" 8 | if [[ "$1" =~ $ONLY_DIGITS ]]; then 9 | REF="HEAD~$REF" 10 | fi; 11 | 12 | GIT_EDITOR="${CUSTOM_EDITOR}" git rebase -i $REF 13 | 14 | # Where are we now ... 15 | git status 16 | -------------------------------------------------------------------------------- /rebase/newbase.t/run.t: -------------------------------------------------------------------------------- 1 | $ chmod +x newbase 2 | $ newbase_test () { CUSTOM_EDITOR=rebase_pass ./newbase $1 2>/dev/null; } 3 | $ git init -b main 4 | Initialized empty Git repository in $TESTCASE_ROOT/.git/ 5 | $ git config user.email "you@test.com" 6 | $ git config user.name "Testy the Tester" 7 | $ git add . 8 | $ git commit -m "Root commit" > /dev/null 9 | $ git commit --allow-empty -m "Commit 1" > /dev/null 10 | $ git commit --allow-empty -m "Commit 2" > /dev/null 11 | $ git checkout -b work 2>1 > /dev/null 12 | $ git commit --allow-empty -m "Commit 3" > /dev/null 13 | $ git commit --allow-empty -m "Commit 4" > /dev/null 14 | $ ONLY_COMMITS="Commit [0-9]+.*" 15 | Rebase on any ref 16 | $ newbase_test main | grep -Po "${ONLY_COMMITS}" 17 | Commit 3 # empty 18 | Commit 4 # empty 19 | $ newbase_test HEAD~4 | grep -Po "${ONLY_COMMITS}" 20 | Commit 1 # empty 21 | Commit 2 # empty 22 | Commit 3 # empty 23 | Commit 4 # empty 24 | When passing a number , it is interpreted as the ref HEAD~ 25 | $ newbase_test 2 | grep -Po "${ONLY_COMMITS}" 26 | Commit 3 # empty 27 | Commit 4 # empty 28 | Fail when missing argument 29 | (not using the newbase_test helper is deliberate, to display the error message) 30 | $ CUSTOM_EDITOR=rebase_pass ./newbase 31 | ./newbase: line 3: 1: Usage: newbase 32 | [1] 33 | -------------------------------------------------------------------------------- /rebase/rebase.ml: -------------------------------------------------------------------------------- 1 | (** Application logic of a custom rebase editor *) 2 | open Qol 3 | 4 | module Column = Components.Column (Components.Merge_ansi_views) 5 | module Column_divided = Components.Column_divided (Components.Merge_ansi_views) 6 | module Column_sliding = Components.Column_sliding (Components.Merge_ansi_views) 7 | module Row = Components.Row (Components.Merge_ansi_views) 8 | module Row_divided = Components.Row_divided (Components.Merge_ansi_views) 9 | module Editing_line = Components.Editing_line 10 | module StringSet = Set.Make (String) 11 | 12 | type fixup_kind = 13 | | Discard_message 14 | | Keep_message 15 | 16 | type rebase_command = 17 | | Pick 18 | | Edit 19 | | Fixup of fixup_kind 20 | | Squash 21 | | Reword 22 | | Exec 23 | | Break 24 | | Drop 25 | | Label of string 26 | | Reset of string 27 | | Merge 28 | | Update of string 29 | 30 | type custom_command = 31 | { explode : Explode_commit.t 32 | ; rename : string option 33 | } 34 | 35 | type rebase_entry = 36 | { command : rebase_command 37 | ; sha1 : string 38 | ; message : string 39 | ; custom : custom_command 40 | } 41 | 42 | let is_fixup = function 43 | | Fixup _ -> true 44 | | _ -> false 45 | ;; 46 | 47 | let string_of_rebase_command = function 48 | | Pick -> "pick" 49 | | Edit -> "edit" 50 | | Fixup Discard_message -> "fixup" 51 | | Fixup Keep_message -> "fixup -C" 52 | | Squash -> "squash" 53 | | Reword -> "reword" 54 | | Exec -> "exec" 55 | | Break -> "break" 56 | | Drop -> "drop" 57 | | Label label -> Printf.sprintf "label <%s>" label 58 | | Reset label -> Printf.sprintf "reset <%s>" label 59 | | Merge -> "merge" 60 | | Update git_ref -> Printf.sprintf "update <%s>" git_ref 61 | ;; 62 | 63 | let message_of_rebase_entry entry = entry.custom.rename |?: entry.message 64 | 65 | let custom_info entry = 66 | match entry.custom.rename with 67 | | Some _ -> "(renamed)" 68 | | _ -> "" 69 | ;; 70 | 71 | let string_of_rebase_entry ({ command; sha1; _ } as entry) = 72 | Printf.sprintf 73 | "%s: %s '%s'%s" 74 | (string_of_rebase_command command) 75 | sha1 76 | (message_of_rebase_entry entry) 77 | (custom_info entry) 78 | ;; 79 | 80 | let git_todo_base { command; sha1; message; _ } = 81 | Printf.sprintf "%s %s %s" (string_of_rebase_command command) sha1 message 82 | ;; 83 | 84 | let escaped message = 85 | message 86 | |> String.to_seq 87 | |> Seq.map (function 88 | | '\'' -> '_' 89 | | c -> c) 90 | |> String.of_seq 91 | ;; 92 | 93 | let exec_initial_commit kept message = 94 | if List.is_empty kept 95 | then [] 96 | else ( 97 | let add_each_kept = List.map (fun f -> Printf.sprintf "git add %s" f) kept in 98 | let commit_kept = Printf.sprintf "git commit -m '%s'" (escaped message) in 99 | add_each_kept @ [ commit_kept ]) 100 | ;; 101 | 102 | let exec_each_exploded_commit exploded message = 103 | List.concat_map 104 | (fun f -> 105 | [ Printf.sprintf "git add %s" f 106 | ; Printf.sprintf {|git commit -m '%s (Exploded from "%s")'|} f (escaped message) 107 | ]) 108 | exploded 109 | ;; 110 | 111 | let git_todo_of_exploded_entry modified_files exploded entry = 112 | if Explode_commit.nothing_exploded exploded 113 | then [] 114 | else ( 115 | let modified = modified_files entry.sha1 in 116 | let kept, exploded = Explode_commit.kept_exploded modified exploded in 117 | let message = message_of_rebase_entry entry in 118 | let exec_kept = exec_initial_commit kept message in 119 | let exec_each = exec_each_exploded_commit exploded message in 120 | let exec = 121 | Printf.sprintf 122 | "exec %s" 123 | (String.concat " && " ("git reset HEAD~" :: (exec_kept @ exec_each))) 124 | in 125 | [ exec ]) 126 | ;; 127 | 128 | (** [git_todo_of_rebase_entry modified_files entry] returns the git rebase command line to execute to apply [entry], in git execution order. These lines are meant to be written to the rebase file handled to git to proceed with the rebase *) 129 | let git_todo_of_rebase_entry 130 | (modified_files : string -> string list) 131 | ({ custom; _ } as entry) 132 | : string list 133 | = 134 | let exec_rename = 135 | custom.rename 136 | |? Printf.sprintf "exec git commit --amend -m '%s'" 137 | |? List.singleton 138 | |?: [] 139 | in 140 | let exec_explode = git_todo_of_exploded_entry modified_files custom.explode entry in 141 | [ git_todo_base entry ] @ exec_rename @ exec_explode 142 | ;; 143 | 144 | (** [git_todo_of_rebase_entries modified_files entries] returns the git rebase command line to execute to apply [entries], in git execution order. These lines are meant to be written to the rebase file handled to git to proceed with the rebase. 145 | 146 | Note that it will not necessarily return 1 line for 1 entry, since a single entry can be translated to multiple git commands, such as intermediary {b exec}s. *) 147 | let git_todo_of_rebase_entries 148 | (modified_files : string -> string list) 149 | (entries : rebase_entry list) 150 | : string list 151 | = 152 | List.concat_map (git_todo_of_rebase_entry modified_files) entries 153 | ;; 154 | 155 | let parse_entry (line : string) : rebase_entry option = 156 | let line = String.trim line in 157 | let parts = String.split_on_char ' ' line in 158 | let concat = String.concat " " 159 | and custom = { explode = Explode_commit.init_nothing; rename = None } in 160 | match parts with 161 | | "pick" :: sha1 :: rest -> Some { command = Pick; sha1; custom; message = concat rest } 162 | | "edit" :: sha1 :: rest -> Some { command = Edit; sha1; custom; message = concat rest } 163 | | "reword" :: sha1 :: rest -> 164 | Some { command = Reword; sha1; custom; message = concat rest } 165 | | "squash" :: sha1 :: rest -> 166 | Some { command = Squash; sha1; custom; message = concat rest } 167 | | "drop" :: sha1 :: rest -> Some { command = Drop; sha1; custom; message = concat rest } 168 | | "fixup" :: "-C" :: sha1 :: rest | "fixup" :: "-c" :: sha1 :: rest -> 169 | Some { command = Fixup Keep_message; sha1; custom; message = concat rest } 170 | | "fixup" :: sha1 :: rest -> 171 | Some { command = Fixup Discard_message; sha1; custom; message = concat rest } 172 | | "exec" :: cmd -> Some { command = Exec; sha1 = ""; custom; message = concat cmd } 173 | | _ -> None 174 | ;; 175 | 176 | let parse_entries lines = List.filter_map parse_entry lines 177 | 178 | let parse_rebase_file f = 179 | let ic = open_in f in 180 | let rec aux acc = 181 | try 182 | let l = input_line ic in 183 | aux (l :: acc) 184 | with 185 | | End_of_file -> List.rev acc 186 | in 187 | Fun.protect ~finally:(fun () -> close_in ic) (fun () -> aux [] |> parse_entries) 188 | ;; 189 | 190 | (** External information about git status that should be provided by the platform *) 191 | module type Rebase_info_external = sig 192 | (** The content of the initial rebase file *) 193 | val entries : rebase_entry list 194 | 195 | (** [modified_files sha1] should return all the files modified by commit with ref [sha1] *) 196 | val modified_files : string -> string list 197 | end 198 | 199 | (** Commands required by [App] *) 200 | type rebase_app_command = 201 | | Exit_with of string list 202 | (** [Exit_with lines] Signals the end of the rebase entries processing, platform should handle back control to git after writing [lines] to the rebase file *) 203 | 204 | module App (Info : Rebase_info_external) : 205 | Tty.Ansi_App with type command = rebase_app_command = struct 206 | include Tty.Ansi_Tea_Base 207 | 208 | type command = rebase_app_command 209 | 210 | module Appearance = struct 211 | type symbols = 212 | { up_arrow_prefix : string 213 | ; down_arrow_prefix : string 214 | ; up_and_down_arrow_prefix : string 215 | ; fixup_prefix : string 216 | ; panel_separator : string 217 | ; panel_bot_left_corner : string 218 | } 219 | 220 | type t = 221 | { symbols : symbols 222 | ; selection_color : Tty.color 223 | } 224 | 225 | let pretty_symbols : symbols = 226 | { up_arrow_prefix = "▲ " 227 | ; down_arrow_prefix = " ▼ " 228 | ; up_and_down_arrow_prefix = "▲▼ " 229 | ; fixup_prefix = " ∟ " 230 | ; panel_separator = " │ " 231 | ; panel_bot_left_corner = " └ " 232 | } 233 | ;; 234 | 235 | let raw_symbols : symbols = 236 | { up_arrow_prefix = "^ " 237 | ; down_arrow_prefix = " v " 238 | ; up_and_down_arrow_prefix = "^v " 239 | ; fixup_prefix = " |_" 240 | ; panel_separator = " | " 241 | ; panel_bot_left_corner = " |_" 242 | } 243 | ;; 244 | 245 | let with_selection_color selection_color t = { t with selection_color } 246 | end 247 | 248 | type mode = 249 | | Navigate (** Navigating between rebase entries *) 250 | | Navigate_files of int (** Navigating between modified files *) 251 | | Move (** Moving a single rebase entry up & down *) 252 | | Rename of Editing_line.t 253 | (** [Rename new_msg] represents an ongoing renaming with message [new_msg] a given rebase entry, differs from [Reword] in that it will actually rename the commit without requiring further user action. *) 254 | | Cli of Editing_line.t (** [Cli s] represents the ongoing typing of a command *) 255 | 256 | module Model : sig 257 | type t = 258 | { entries : rebase_entry array 259 | ; cursor : int 260 | ; mode : mode 261 | ; dimensions : Tty.position 262 | ; appearance : Appearance.t 263 | } 264 | 265 | val entry_count : t -> int 266 | val is_navigate_files : t -> bool 267 | val move_up : t -> t 268 | val move_down : t -> t 269 | val set_fixup : t -> fixup_kind -> t 270 | val set_drop : t -> t 271 | val set_pick : t -> t 272 | val set_rename : t -> string -> t 273 | val set_explode : t -> Explode_commit.t -> t 274 | val switch_explode : t -> t 275 | val switch_mode : mode -> t -> t 276 | val with_appearance : Appearance.t -> t -> t 277 | val renaming : t -> Editing_line.t -> t 278 | val current_entry : t -> rebase_entry 279 | val current_message : t -> string 280 | val current_modified_files : t -> string list 281 | end = struct 282 | type t = 283 | { entries : rebase_entry array 284 | ; cursor : int (** The current selected entry index within [entries] *) 285 | ; mode : mode (** Crurrent [mode] *) 286 | ; dimensions : Tty.position (** Current dimensions of the display *) 287 | ; appearance : Appearance.t (** Appearance config *) 288 | } 289 | 290 | let entry_count model = Array.length model.entries 291 | 292 | let is_navigate_files model = 293 | match model.mode with 294 | | Navigate_files _ -> true 295 | | _ -> false 296 | ;; 297 | 298 | let is_explode entry = not @@ Explode_commit.nothing_exploded entry.custom.explode 299 | let current_entry model = model.entries.(model.cursor) 300 | let current_sha1 model = (current_entry model).sha1 301 | let current_modified_files model = Info.modified_files (current_sha1 model) 302 | 303 | let swap arr a b = 304 | let copy = Array.copy arr in 305 | let a_copy = arr.(a) in 306 | copy.(a) <- arr.(b); 307 | copy.(b) <- a_copy; 308 | copy 309 | ;; 310 | 311 | let swap_entries model ~source_cursor ~target_cursor = 312 | { model with 313 | cursor = target_cursor 314 | ; entries = swap model.entries source_cursor target_cursor 315 | } 316 | ;; 317 | 318 | let entry_at_cursor model cursor = model.entries.(cursor) 319 | 320 | let entry_at_cursor_is_fixup model cursor = 321 | is_fixup (entry_at_cursor model cursor).command 322 | ;; 323 | 324 | let move_up ({ cursor; _ } as model) = 325 | if cursor <= 0 || (cursor = 1 && entry_at_cursor_is_fixup model cursor) 326 | then model 327 | else swap_entries model ~source_cursor:cursor ~target_cursor:(cursor - 1) 328 | ;; 329 | 330 | let move_down ({ cursor; entries; _ } as model) = 331 | if cursor >= Array.length entries - 1 332 | || (cursor = 0 && entry_at_cursor_is_fixup model (cursor + 1)) 333 | then model 334 | else swap_entries model ~source_cursor:cursor ~target_cursor:(cursor + 1) 335 | ;; 336 | 337 | let set_rebase_command ({ cursor; entries; _ } as model) cmd = 338 | let current = entries.(cursor) in 339 | let copy = Array.copy entries in 340 | copy.(cursor) <- { current with command = cmd }; 341 | { model with entries = copy } 342 | ;; 343 | 344 | let set_fixup model fixup_kind = 345 | if model.cursor = 0 then model else set_rebase_command model (Fixup fixup_kind) 346 | ;; 347 | 348 | let set_drop model = set_rebase_command model Drop 349 | let set_pick model = set_rebase_command model Drop 350 | 351 | let set_rename ({ cursor; entries; _ } as model) (name : string) = 352 | let current = entries.(cursor) in 353 | let copy = Array.copy entries in 354 | copy.(cursor) 355 | <- { current with custom = { current.custom with rename = Some name } }; 356 | { model with entries = copy; mode = Navigate } 357 | ;; 358 | 359 | let set_explode model explode = 360 | let entry = model.entries.(model.cursor) in 361 | let copy = Array.copy model.entries in 362 | copy.(model.cursor) <- { entry with custom = { entry.custom with explode } }; 363 | { model with entries = copy } 364 | ;; 365 | 366 | let switch_explode ({ cursor; entries; _ } as model) = 367 | let current = entries.(cursor) in 368 | let copy = Array.copy entries in 369 | copy.(cursor) 370 | <- { current with 371 | custom = 372 | (if is_explode current 373 | then { current.custom with explode = Explode_commit.init_nothing } 374 | else 375 | { current.custom with 376 | explode = Explode_commit.init_all (Info.modified_files current.sha1) 377 | }) 378 | }; 379 | { model with entries = copy; mode = Navigate } 380 | ;; 381 | 382 | let switch_mode mode model = { model with mode } 383 | let with_appearance appearance model = { model with appearance } 384 | let renaming model s = switch_mode (Rename s) model 385 | let current_message model = message_of_rebase_entry @@ current_entry model 386 | end 387 | 388 | type model = Model.t 389 | 390 | let modified_count model = List.length (Model.current_modified_files model) 391 | 392 | module View : sig 393 | val view : model -> Tty.ansi_view_item list 394 | end = struct 395 | let move_prefix (model : model) = 396 | let is_first = model.cursor = 0 397 | and is_last = model.cursor = Model.entry_count model - 1 in 398 | let symbols = model.appearance.symbols in 399 | if is_first && is_last 400 | then " " 401 | else if is_first 402 | then symbols.down_arrow_prefix 403 | else if is_last 404 | then symbols.up_arrow_prefix 405 | else symbols.up_and_down_arrow_prefix 406 | ;; 407 | 408 | let fixup_prefix (model : model) = model.appearance.symbols.fixup_prefix 409 | 410 | let renaming_entry_component { command; sha1; _ } editing = 411 | let style = Tty.Default_style.default_style in 412 | let left = 413 | Printf.sprintf "%s: %s '" (string_of_rebase_command command) sha1 414 | |> Components.Text_line.component 415 | |> Components.to_ansi_view_component style 416 | and right = 417 | "'(renaming)" 418 | |> Components.Text_line.component 419 | |> Components.to_ansi_view_component style 420 | and editing_component = 421 | Editing_line.component editing 422 | |> Components.positioned_to_ansi_view_component Tty.Default_style.default_style 423 | in 424 | Row.component [ left; editing_component; right ] 425 | ;; 426 | 427 | let rebase_entry_component (model : model) (i : int) (e : rebase_entry) 428 | : Tty.ansi_view_item list Components.component 429 | = 430 | let base_style = 431 | { Tty.Default_style.default_style with striked = e.command = Drop } 432 | in 433 | let style = 434 | if i = model.cursor 435 | then { base_style with bg_color = Some model.appearance.selection_color } 436 | else base_style 437 | in 438 | let prefix = if is_fixup e.command then fixup_prefix model else "" in 439 | match model.mode with 440 | | Navigate | Cli _ | Navigate_files _ -> 441 | Components.Text_line.component (prefix ^ string_of_rebase_entry e) 442 | |> Components.to_ansi_view_component style 443 | | Move when model.cursor <> i -> 444 | Components.Text_line.component (prefix ^ string_of_rebase_entry e) 445 | |> Components.to_ansi_view_component style 446 | | Rename _ when model.cursor <> i -> 447 | Components.Text_line.component (prefix ^ string_of_rebase_entry e) 448 | |> Components.to_ansi_view_component style 449 | | Move -> 450 | Components.Text_line.component (move_prefix model ^ string_of_rebase_entry e) 451 | |> Components.to_ansi_view_component style 452 | | Rename s -> renaming_entry_component e s 453 | ;; 454 | 455 | let cli_view (model : model) : Tty.ansi_view_item list Components.component = 456 | let style = Tty.Default_style.default_style in 457 | match model.mode with 458 | | Cli s -> 459 | Editing_line.component s |> Components.positioned_to_ansi_view_component style 460 | | _ -> Components.Text_line.component "" |> Components.to_ansi_view_component style 461 | ;; 462 | 463 | let cli_separator = 464 | Components.Text_line.component "" 465 | |> Components.to_ansi_view_component Tty.Default_style.default_style 466 | ;; 467 | 468 | let panel_separator (model : model) = 469 | let files_count = modified_count model in 470 | let symbols = model.appearance.symbols in 471 | if files_count = 0 472 | then Column.component [] 473 | else 474 | List.init files_count (fun _ -> symbols.panel_separator) 475 | @ [ symbols.panel_bot_left_corner ] 476 | |> List.map (fun l -> 477 | Components.Text_line.component l 478 | |> Components.to_ansi_view_component Tty.Default_style.default_style) 479 | |> Column.component 480 | ;; 481 | 482 | let is_exploded (model : model) file = 483 | Explode_commit.is_exploded (Model.current_entry model).custom.explode file 484 | ;; 485 | 486 | let line_of_file_entry model file = 487 | if is_exploded model file then Printf.sprintf "(x) %s" file else file 488 | ;; 489 | 490 | let right_panel_view (model : model) = 491 | let selected_index = 492 | match model.mode with 493 | | Navigate_files i -> Some i 494 | | _ -> None 495 | in 496 | let style i = 497 | if selected_index = Some i 498 | then 499 | { Tty.Default_style.default_style with 500 | bg_color = Some model.appearance.selection_color 501 | } 502 | else Tty.Default_style.default_style 503 | in 504 | let file_entries = 505 | Model.current_modified_files model 506 | |> List.map (line_of_file_entry model) 507 | |> Array.of_list 508 | |> Array.map Components.Text_line.component 509 | in 510 | Column_sliding.component 511 | (fun i e -> e |> Components.to_ansi_view_component (style i)) 512 | file_entries 513 | (selected_index |?: 0) 514 | ;; 515 | 516 | let left_panel_view model = 517 | Column_sliding.component (rebase_entry_component model) model.entries model.cursor 518 | ;; 519 | 520 | let view (model : model) : Tty.ansi_view_item list = 521 | let constraints = 522 | Components.Constraints. 523 | { col_start = 1 524 | ; row_start = 1 525 | ; width = model.dimensions.col 526 | ; height = model.dimensions.row 527 | } 528 | in 529 | let left_portion, right_portion = 530 | if Model.is_navigate_files model then 1, 7 else 6, 2 531 | in 532 | let left_right_panel = 533 | Row_divided.component 534 | [ left_panel_view model, left_portion 535 | ; panel_separator model, 1 536 | ; right_panel_view model, right_portion 537 | ] 538 | in 539 | let full_screen = 540 | Column_divided.component 541 | [ left_right_panel, model.dimensions.row - 2 542 | ; cli_separator, 1 543 | ; cli_view model, 1 544 | ] 545 | in 546 | first @@ full_screen constraints 547 | ;; 548 | end 549 | 550 | let view = View.view 551 | 552 | let init = 553 | Model. 554 | { entries = Array.of_list Info.entries 555 | ; cursor = 0 556 | ; mode = Navigate 557 | ; dimensions = { row = 25; col = 80 } 558 | ; appearance = { symbols = Appearance.pretty_symbols; selection_color = Tty.Cyan } 559 | } 560 | ;; 561 | 562 | let exit_with (model : model) = 563 | ( model 564 | , [ Exit_with 565 | (Array.to_list model.entries |> git_todo_of_rebase_entries Info.modified_files) 566 | ] ) 567 | ;; 568 | 569 | let inline (model : model) = 570 | let lines = 571 | git_todo_of_rebase_entries Info.modified_files (Array.to_list model.entries) 572 | in 573 | let new_entries = parse_entries lines |> Array.of_list in 574 | { model with mode = Navigate; entries = new_entries } 575 | ;; 576 | 577 | let navigate_files (model : model) = 578 | if modified_count model = 0 then model else { model with mode = Navigate_files 0 } 579 | ;; 580 | 581 | let toggle_explode_file (model : model) (i : int) = 582 | let { custom; sha1; _ } = Model.current_entry model in 583 | let modified = Info.modified_files sha1 in 584 | let updated = Explode_commit.toggle_i modified custom.explode i in 585 | Model.set_explode model updated 586 | ;; 587 | 588 | let update_cli_command cmd (Model.{ appearance; _ } as model) = 589 | let with_selection_color color model = 590 | Model.with_appearance (Appearance.with_selection_color color appearance) model 591 | in 592 | match String.trim cmd |> String.split_on_char ' ' with 593 | | [ ":q" ] -> exit_with model 594 | | [ ":abort" ] -> exit_with init 595 | | [ ":inline" ] -> inline model, [] 596 | | [ ":pretty" ] -> 597 | ( { model with 598 | appearance = { model.appearance with symbols = Appearance.pretty_symbols } 599 | } 600 | |> Model.switch_mode Navigate 601 | , [] ) 602 | | [ ":raw" ] -> 603 | ( { model with 604 | appearance = { model.appearance with symbols = Appearance.raw_symbols } 605 | } 606 | |> Model.switch_mode Navigate 607 | , [] ) 608 | | [ ":color"; "red" ] -> with_selection_color Red model, [] 609 | | [ ":color"; "green" ] -> with_selection_color Green model, [] 610 | | [ ":color"; "blue" ] -> with_selection_color Blue model, [] 611 | | [ ":color"; "cyan" ] -> with_selection_color Cyan model, [] 612 | | [ ":color"; "magenta" ] -> with_selection_color Magenta model, [] 613 | | [ ":color"; "yellow" ] -> with_selection_color Yellow model, [] 614 | | [ ":color"; "white" ] -> with_selection_color White model, [] 615 | | _ -> Model.switch_mode Navigate model, [] 616 | ;; 617 | 618 | let update (model : model) (event : Tty.ansi_event) = 619 | match model.mode, event with 620 | | Navigate, Up -> { model with cursor = max 0 (model.cursor - 1) }, [] 621 | | Navigate, Down -> 622 | { model with cursor = min (Model.entry_count model - 1) (model.cursor + 1) }, [] 623 | | Navigate_files i, Up -> Model.switch_mode (Navigate_files (max 0 (i - 1))) model, [] 624 | | Navigate_files i, Down -> 625 | ( Model.switch_mode (Navigate_files (min (modified_count model - 1) (i + 1))) model 626 | , [] ) 627 | | Navigate_files _, Char '\t' -> Model.switch_mode Navigate model, [] 628 | | Navigate, Right -> Model.switch_mode Move model, [] 629 | | Move, Up -> Model.move_up model, [] 630 | | Move, Down -> Model.move_down model, [] 631 | | Move, Left -> Model.switch_mode Navigate model, [] 632 | | Rename editing_name, Enter -> 633 | Model.set_rename model (Editing_line.to_string editing_name), [] 634 | | Rename s, Char c -> Model.renaming model (Editing_line.append_char c s), [] 635 | | Rename s, Del -> Model.renaming model (Editing_line.del s), [] 636 | | Rename s, Suppr -> Model.renaming model (Editing_line.suppr s), [] 637 | | Rename s, Left -> Model.renaming model (Editing_line.left s), [] 638 | | Rename s, Right -> Model.renaming model (Editing_line.right s), [] 639 | | Cli s, Char c -> { model with mode = Cli (Editing_line.append_char c s) }, [] 640 | | Cli s, Del -> { model with mode = Cli (Editing_line.del s) }, [] 641 | | Cli s, Suppr -> { model with mode = Cli (Editing_line.suppr s) }, [] 642 | | Cli s, Left -> { model with mode = Cli (Editing_line.left s) }, [] 643 | | Cli s, Right -> { model with mode = Cli (Editing_line.right s) }, [] 644 | | Cli s, Enter -> update_cli_command (Editing_line.to_string s) model 645 | | [%cross_match (Navigate, Move), Char '\t'] -> navigate_files model, [] 646 | | [%cross_match (Navigate, Move, Navigate_files [%cross_any]), Char ':'] -> 647 | Model.switch_mode (Cli (Editing_line.init ":")) model, [] 648 | | [%cross_match 649 | (Rename [%cross_any], Cli [%cross_any], Navigate_files [%cross_any]), Esc] -> 650 | Model.switch_mode Navigate model, [] 651 | | [%cross_match (Navigate, Move), (Char 'd', Char 'D', Del, Suppr)] -> 652 | Model.set_drop model, [] 653 | | [%cross_match (Navigate, Move), Char 'f'] -> 654 | Model.set_fixup model Discard_message, [] 655 | | [%cross_match (Navigate, Move), Char 'F'] -> Model.set_fixup model Keep_message, [] 656 | | [%cross_match (Navigate, Move), (Char 'p', Char 'P')] -> Model.set_pick model, [] 657 | | [%cross_match (Navigate, Move), Char 'r'] -> 658 | Model.renaming model (Editing_line.init @@ Model.current_message model), [] 659 | | [%cross_match (Navigate, Move), Char 'R'] -> 660 | Model.renaming model @@ Editing_line.empty, [] 661 | | [%cross_match (Navigate, Move), (Char 'x', Char 'X')] -> 662 | Model.switch_explode model, [] 663 | | [%cross_match Navigate_files i, (Char 'x', Char 'X')] -> 664 | toggle_explode_file model i, [] 665 | | _, Size dimensions -> { model with dimensions }, [] 666 | | _ -> model, [] 667 | ;; 668 | end 669 | -------------------------------------------------------------------------------- /rebase/rebase_edit.ml: -------------------------------------------------------------------------------- 1 | (** Custom git-rebase editor *) 2 | 3 | module Terminal_platform_with_exit 4 | (Terminal : Tty.Posix_terminal) 5 | (Target : sig 6 | val file : string 7 | end) : Tty.Ansi_Platform with type command = Rebase.rebase_app_command = struct 8 | include Tty.Posix_terminal_platform (Terminal) 9 | 10 | type command = Rebase.rebase_app_command 11 | 12 | let write_git_entries (f : string) (content : string list) = 13 | let oc = open_out f in 14 | Fun.protect 15 | ~finally:(fun () -> close_out oc) 16 | (fun () -> List.iter (Qol.Out_channel.output_line oc) content) 17 | ;; 18 | 19 | (** Handle application exit by writing the current application rebase entries to the target rebase file and exiting the program *) 20 | let handle_commands = function 21 | | Rebase.Exit_with entries :: _ -> 22 | write_git_entries Target.file entries; 23 | restore_terminal_state (); 24 | exit 0 25 | | _ -> () 26 | ;; 27 | end 28 | 29 | module Rebase_info_of_file (F : sig 30 | val file : string 31 | end) = 32 | struct 33 | module Cache = Hashtbl.Make (String) 34 | 35 | type cache = string list Cache.t 36 | 37 | let cache : cache = Cache.create 50 38 | 39 | let cached sha1 lazy_files_result = 40 | match Cache.find_opt cache sha1 with 41 | | Some v -> v 42 | | None -> 43 | let v = Lazy.force lazy_files_result in 44 | Cache.add cache sha1 v; 45 | v 46 | ;; 47 | 48 | let entries = Rebase.parse_rebase_file F.file 49 | 50 | (** Give modified files for a given commit by actually calling git. Cached to avoid redundant program calls *) 51 | let modified_files sha1 = 52 | cached sha1 53 | @@ lazy 54 | (Qol_unix.command 55 | "git" 56 | [| "diff-tree"; "--no-commit-id"; "--name-only"; "-r"; "--root"; sha1 |]) 57 | ;; 58 | end 59 | 60 | let () = 61 | (* The rebase file created by git and passed as first argument to the editor *) 62 | let rebase_file = Sys.argv.(1) in 63 | let module Rebase_file = struct 64 | let file = rebase_file 65 | end 66 | in 67 | let module Info = Rebase_info_of_file (Rebase_file) in 68 | let module Terminal = struct 69 | let terminal_in = Unix.stdin 70 | let terminal_out = Out_channel.stdout 71 | 72 | module Style = Tty.Default_style 73 | end 74 | in 75 | let module Terminal_platform = Terminal_platform_with_exit (Terminal) (Rebase_file) in 76 | Tea.loop_app (module Rebase.App (Info)) (module Terminal_platform) 77 | ;; 78 | -------------------------------------------------------------------------------- /rebase/rebase_file_sample.txt: -------------------------------------------------------------------------------- 1 | pick 8e46867 Add default style to Tty module 2 | pick ee88f85 Make test output more readable 3 | pick e24e6e4 Move setup logic to Platform modules 4 | pick 8a6ece0 wip 5 | 6 | # Rebase fabb4d9..8a6ece0 onto fabb4d9 (4 commands) 7 | # 8 | # Commands: 9 | # p, pick = use commit 10 | # r, reword = use commit, but edit the commit message 11 | # e, edit = use commit, but stop for amending 12 | # s, squash = use commit, but meld into previous commit 13 | # f, fixup [-C | -c] = like 'squash' but keep only the previous 14 | # commit's log message, unless -C is used, in which case 15 | # keep only this commit's message; -c is same as -C but 16 | # opens the editor 17 | # x, exec = run command (the rest of the line) using shell 18 | # b, break = stop here (continue rebase later with 'git rebase --continue') 19 | # d, drop = remove commit 20 | # l, label