2024-06-22 20:11:10 +03:00
|
|
|
type file_contents = {
|
|
|
|
lines : Pretty.doc array;
|
|
|
|
offset : int;
|
|
|
|
}
|
|
|
|
|
2024-02-04 17:26:18 +03:00
|
|
|
type tree =
|
2024-06-22 20:11:10 +03:00
|
|
|
| File of string * file_contents lazy_t
|
2024-02-04 17:26:18 +03:00
|
|
|
| Dir of string * tree array
|
|
|
|
|
|
|
|
let file_name = function
|
2024-03-24 16:21:30 +03:00
|
|
|
| File (name, _) -> name
|
|
|
|
| Dir (name, _) -> name
|
2024-02-04 17:26:18 +03:00
|
|
|
|
2024-02-25 14:53:44 +03:00
|
|
|
(* A files comparison:
|
|
|
|
|
2024-03-23 13:26:12 +03:00
|
|
|
1. Directories before files
|
|
|
|
2. Otherwise, lexicographically
|
2024-02-25 14:53:44 +03:00
|
|
|
*)
|
|
|
|
let order_files t1 t2 =
|
|
|
|
match (t1, t2) with
|
2024-03-23 13:26:12 +03:00
|
|
|
| Dir _, File _ -> -1
|
|
|
|
| File _, Dir _ -> 1
|
2024-03-24 16:21:30 +03:00
|
|
|
| _, _ -> String.compare (file_name t1) (file_name t2)
|
2024-02-25 14:53:44 +03:00
|
|
|
|
|
|
|
let rec sort_tree = function
|
2024-03-24 16:21:30 +03:00
|
|
|
| File (name, contents) -> File (name, contents)
|
2024-02-25 14:53:44 +03:00
|
|
|
| Dir (name, children) ->
|
2024-03-23 13:26:12 +03:00
|
|
|
Array.sort order_files children;
|
|
|
|
Dir (name, Array.map sort_tree children)
|
2024-02-25 14:53:44 +03:00
|
|
|
|
2024-03-24 16:21:30 +03:00
|
|
|
(* Reads file contents using 'bat' to have pretty syntax highlighting *)
|
|
|
|
let read_file_contents path =
|
|
|
|
let cmd =
|
2024-06-22 20:11:10 +03:00
|
|
|
"bat --style=numbers,changes --color=always --italic-text=always \
|
|
|
|
--paging=never --terminal-width=80 " ^ path
|
|
|
|
in
|
|
|
|
let contents = Shell.proc_stdout cmd in
|
|
|
|
let lines =
|
|
|
|
contents
|
|
|
|
|> String.split_on_char '\n'
|
|
|
|
|> List.map Pretty.str
|
|
|
|
|> Array.of_list
|
2024-03-24 16:21:30 +03:00
|
|
|
in
|
2024-06-22 20:11:10 +03:00
|
|
|
let offset = 0 in
|
|
|
|
{ lines; offset }
|
2024-03-24 16:21:30 +03:00
|
|
|
|
2024-02-25 14:53:44 +03:00
|
|
|
let rec to_tree path =
|
|
|
|
if Sys.is_directory path then
|
2024-03-23 13:26:12 +03:00
|
|
|
let children =
|
|
|
|
Array.map
|
|
|
|
(fun child_name -> to_tree (Filename.concat path child_name))
|
|
|
|
(Sys.readdir path)
|
2024-02-25 14:53:44 +03:00
|
|
|
in
|
2024-03-23 15:06:36 +03:00
|
|
|
let dirname = Filename.basename path in
|
2024-02-25 14:53:44 +03:00
|
|
|
Dir (dirname, children)
|
2024-03-24 16:21:30 +03:00
|
|
|
else File (Filename.basename path, lazy (read_file_contents path))
|
2024-02-25 14:53:44 +03:00
|
|
|
|
2024-03-23 13:26:12 +03:00
|
|
|
let read_tree path = path |> to_tree |> sort_tree
|
2024-02-25 14:53:44 +03:00
|
|
|
|
2024-06-22 21:47:15 +03:00
|
|
|
type dir_cursor = {
|
2024-03-23 13:26:12 +03:00
|
|
|
pos : int;
|
|
|
|
files : tree array;
|
|
|
|
}
|
2024-02-04 17:26:18 +03:00
|
|
|
|
2024-06-22 21:47:15 +03:00
|
|
|
type cursor =
|
|
|
|
| Dir_cursor of dir_cursor
|
2024-06-23 15:42:54 +03:00
|
|
|
| File_cursor of file_contents
|
2024-06-22 21:47:15 +03:00
|
|
|
|
2024-03-23 15:10:59 +03:00
|
|
|
let file_at cursor = cursor.files.(cursor.pos)
|
2024-02-04 19:51:25 +03:00
|
|
|
|
2024-03-23 13:26:12 +03:00
|
|
|
type zipper = {
|
2024-06-22 21:47:15 +03:00
|
|
|
parents : dir_cursor list;
|
2024-03-23 13:26:12 +03:00
|
|
|
current : cursor;
|
|
|
|
}
|
2024-02-04 17:26:18 +03:00
|
|
|
|
2024-06-22 21:47:15 +03:00
|
|
|
let zip_it trees =
|
|
|
|
{ parents = []; current = Dir_cursor { pos = 0; files = trees } }
|
2024-02-25 14:53:44 +03:00
|
|
|
|
2024-02-25 15:08:17 +03:00
|
|
|
let zipper_parents zipper =
|
2024-03-23 15:10:59 +03:00
|
|
|
List.map (fun cursor -> file_name (file_at cursor)) zipper.parents
|
2024-02-25 15:08:17 +03:00
|
|
|
|
2024-06-22 21:47:15 +03:00
|
|
|
(* TODO: Horrible hardcoding of maximum lines view *)
|
|
|
|
let span = 40
|
|
|
|
|
2024-02-04 19:51:25 +03:00
|
|
|
let go_down zipper =
|
2024-06-22 21:47:15 +03:00
|
|
|
match zipper.current with
|
|
|
|
| Dir_cursor cursor ->
|
|
|
|
let len = Array.length cursor.files in
|
|
|
|
let new_pos = (cursor.pos + 1) mod len in
|
|
|
|
let new_cursor = Dir_cursor { cursor with pos = new_pos } in
|
|
|
|
{ zipper with current = new_cursor }
|
2024-06-23 15:42:54 +03:00
|
|
|
| File_cursor cursor ->
|
2024-06-22 21:47:15 +03:00
|
|
|
let new_offset = cursor.offset + 1 in
|
2024-06-23 15:42:54 +03:00
|
|
|
let new_cursor = File_cursor { cursor with offset = new_offset } in
|
2024-06-22 21:47:15 +03:00
|
|
|
let len = Array.length cursor.lines in
|
|
|
|
if new_offset + span > len then zipper
|
|
|
|
else { zipper with current = new_cursor }
|
2024-02-04 17:26:18 +03:00
|
|
|
|
2024-02-04 19:51:25 +03:00
|
|
|
let go_up zipper =
|
2024-06-22 21:47:15 +03:00
|
|
|
match zipper.current with
|
|
|
|
| Dir_cursor cursor ->
|
|
|
|
let len = Array.length cursor.files in
|
|
|
|
let new_pos = (cursor.pos + len - 1) mod len in
|
|
|
|
let new_cursor = Dir_cursor { cursor with pos = new_pos } in
|
|
|
|
{ zipper with current = new_cursor }
|
2024-06-23 15:42:54 +03:00
|
|
|
| File_cursor cursor ->
|
2024-06-22 21:47:15 +03:00
|
|
|
let new_offset = max 0 (cursor.offset - 1) in
|
2024-06-23 15:42:54 +03:00
|
|
|
let new_cursor = File_cursor { cursor with offset = new_offset } in
|
2024-06-22 21:47:15 +03:00
|
|
|
{ zipper with current = new_cursor }
|
2024-02-25 15:16:50 +03:00
|
|
|
|
|
|
|
let go_next zipper =
|
2024-06-22 21:47:15 +03:00
|
|
|
match zipper.current with
|
|
|
|
| File_cursor _ -> zipper
|
|
|
|
| Dir_cursor cursor -> (
|
|
|
|
let next = file_at cursor in
|
|
|
|
match next with
|
2024-06-23 15:42:54 +03:00
|
|
|
| File (_name, contents) ->
|
2024-06-22 21:47:15 +03:00
|
|
|
{
|
|
|
|
parents = cursor :: zipper.parents;
|
2024-06-23 15:42:54 +03:00
|
|
|
current = File_cursor (Lazy.force contents);
|
2024-06-22 21:47:15 +03:00
|
|
|
}
|
|
|
|
| Dir (_, next) ->
|
|
|
|
if Array.length next = 0 then zipper
|
|
|
|
else
|
|
|
|
{
|
|
|
|
parents = cursor :: zipper.parents;
|
|
|
|
current = Dir_cursor { pos = 0; files = next };
|
|
|
|
})
|
2024-02-25 15:16:50 +03:00
|
|
|
|
|
|
|
let go_back zipper =
|
|
|
|
match zipper.parents with
|
|
|
|
| [] -> zipper
|
2024-06-22 21:47:15 +03:00
|
|
|
| current :: parents -> { parents; current = Dir_cursor current }
|