diff --git a/.gitmodules b/.gitmodules index 8b354d2..65ecf27 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,6 +1,4 @@ -[submodule "ocaml-ci"] - path = ocaml-ci - url = https://github.com/ocaml-ci/ocaml-ci.git [submodule "lwd"] path = lwd url = https://github.com/let-def/lwd.git + branch = master diff --git a/.ocamlformat b/.ocamlformat index 2341169..3f42c62 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,3 +1,3 @@ -version = 0.15.0 +version = 0.24.1 profile = conventional break-infix = fit-or-vertical diff --git a/citty.opam b/citty.opam index fd5804d..3d39ba3 100644 --- a/citty.opam +++ b/citty.opam @@ -1,16 +1,44 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" +synopsis: "CI in TTY" +maintainer: ["Frédéric Bour"] +authors: ["Frédéric Bour"] license: "MIT" +homepage: "https://github.com/ocurrent/citty" +bug-reports: "https://github.com/ocurrent/citty/issues" +depends: [ + "dune" {>= "3.6"} + "current_rpc" + "capnp" + "capnp-rpc-unix" + "lwt" {>= "5.6.1"} + "notty" {>= "0.2.3"} + "lwd" {>= "0.3"} + "nottui" {>= "0.3"} + "nottui-lwt" {>= "0.3"} + "ocaml-ci-api" + "fpath" + "fmt" + "logs" + "cmdliner" {>= "1.1.0"} + "odoc" {with-doc} +] build: [ - ["dune" "subst"] {pinned} - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j" jobs] {with-test} - ["dune" "build" "-p" name "@doc"] {with-doc} + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/ocurrent/citty.git" +pin-depends: [ + [ "ocaml-ci-api.dev" "git+https://github.com/ocurrent/ocaml-ci.git#9b9a3d77eb2fd51017e5934b533a6d8fb190323b" ] # master + [ "solver-service-api.dev" "git+https://github.com/ocurrent/solver-service.git#2e0695f844c45048a6e40e2d45a2aaff46c9c163" ] # solver-ci ] -authors: ["Frédéric Bour"] -maintainer: "Frédéric Bour" -bug-reports: "https://github.com/ocaml-ci/citty/issues" -homepage: "https://github.com/ocaml-ci/citty" -dev-repo: "git+https://github.com/ocaml-ci/citty.git" -synopsis: "CI in TTY" -depends: ["current_rpc" "capnp" "capnp-rpc-unix" "lwt" "notty" "fpath" "fmt"] diff --git a/citty.opam.template b/citty.opam.template new file mode 100644 index 0000000..37ecc7f --- /dev/null +++ b/citty.opam.template @@ -0,0 +1,4 @@ +pin-depends: [ + [ "ocaml-ci-api.dev" "git+https://github.com/ocurrent/ocaml-ci.git#9b9a3d77eb2fd51017e5934b533a6d8fb190323b" ] # master + [ "solver-service-api.dev" "git+https://github.com/ocurrent/solver-service.git#2e0695f844c45048a6e40e2d45a2aaff46c9c163" ] # solver-ci +] diff --git a/dune b/dune index 130475c..2eaa08e 100644 --- a/dune +++ b/dune @@ -1 +1 @@ -(vendored_dirs lwd ocaml-ci) +(vendored_dirs lwd) diff --git a/dune-project b/dune-project index 04880a0..0628e58 100644 --- a/dune-project +++ b/dune-project @@ -1,13 +1,27 @@ -(lang dune 2.0) - +(lang dune 3.6) (name citty) (generate_opam_files true) -(source (github ocaml-ci/citty)) + +(source (github ocurrent/citty)) (authors "Frédéric Bour") +(maintainers "Frédéric Bour") (license "MIT") (package (name citty) (synopsis "CI in TTY") - (depends current_rpc capnp capnp-rpc-unix lwt notty fpath fmt)) + (depends + current_rpc + capnp + capnp-rpc-unix + (lwt (>= 5.6.1)) + (notty (>= 0.2.3)) + (lwd (>= 0.3)) + (nottui (>= 0.3)) + (nottui-lwt (>= 0.3)) + ocaml-ci-api + fpath + fmt + logs + (cmdliner (>= 1.1.0)))) diff --git a/lwd b/lwd index 6f05c93..d367a72 160000 --- a/lwd +++ b/lwd @@ -1 +1 @@ -Subproject commit 6f05c93463ab024a989b6a8c815ffb6fd6252d58 +Subproject commit d367a72312af1e900952742f7252c409ee3d6ecb diff --git a/ocaml-ci b/ocaml-ci deleted file mode 160000 index f44ec01..0000000 --- a/ocaml-ci +++ /dev/null @@ -1 +0,0 @@ -Subproject commit f44ec011f34b9f991f73a448d664048cf78996fe diff --git a/src/dune b/src/dune index cd5204e..49b48ca 100644 --- a/src/dune +++ b/src/dune @@ -1,5 +1,17 @@ (executable (name main) + (public_name citty) (modes byte exe) - (libraries ocaml-ci-api current_rpc capnp-rpc-unix lwd nottui nottui-lwt - nottui-widgets)) + (libraries + ocaml-ci-api + current_rpc + capnp-rpc-unix + lwd + nottui + nottui-lwt + fmt + fmt.cli + fmt.tty + logs + logs.fmt + logs.cli)) diff --git a/src/main.ml b/src/main.ml index f4219a4..0830470 100644 --- a/src/main.ml +++ b/src/main.ml @@ -8,29 +8,16 @@ module W = Widgets module Pane = W.Pane let clampi mn mx a : int = if a > mx then mx else if a < mn then mn else a - let header = Lwd.var W.empty - let body = Lwd.var W.empty - let footer = Lwd.var W.empty let spinner = let rec frames = - "⠋" - :: "⠙" - :: "⠹" - :: "⠸" - :: "⠼" - :: "⠴" - :: "⠦" - :: "⠧" - :: "⠇" - :: "⠏" - :: frames + "⠋" :: "⠙" :: "⠹" :: "⠸" :: "⠼" :: "⠴" :: "⠦" :: "⠧" :: "⠇" :: "⠏" :: frames in Lwd.prim - ~acquire:(fun () -> + ~acquire:(fun _self -> let running = ref true in let frame = Lwd.var frames in let rec next_frame () = @@ -41,14 +28,14 @@ let spinner = in Lwt.async next_frame; (running, Lwd.get frame)) - ~release:(fun (running, _) -> running := false) + ~release:(fun _self (running, _) -> running := false) |> Lwd.get_prim - |> Lwd.map (fun (_running, var) -> var) + |> Lwd.map ~f:(fun (_running, var) -> var) |> Lwd.join - |> Lwd.map List.hd + |> Lwd.map ~f:List.hd let ui = - let place_ui_var v = Lwd.(v |> get |> join |> map (Ui.resize ~w:0)) in + let place_ui_var v = Lwd.(v |> get |> join |> map ~f:(Ui.resize ~w:0)) in Lwd_utils.pack Ui.pack_y [ place_ui_var header; Lwd.get body |> Lwd.join; place_ui_var footer ] @@ -81,10 +68,9 @@ let import_ci_ref ~vat = function | Some home -> let path = Filename.concat home ".ocaml-ci.cap" in if Sys.file_exists path then Capnp_rpc_unix.Cap_file.load vat path - else failwithf "Default cap file %S not found!" path ) + else failwithf "Default cap file %S not found!" path) let log_file = Filename.temp_file "citty" ".log" - let () = at_exit (fun () -> Sys.remove log_file) let open_in_editor refresh log_lines = function @@ -100,8 +86,7 @@ let open_in_editor refresh log_lines = function match Sys.getenv_opt "EDITOR" with | Some x -> [ x ] | None -> ( - match Sys.getenv_opt "PAGER" with Some x -> [ x ] | None -> [] ) - ) + match Sys.getenv_opt "PAGER" with Some x -> [ x ] | None -> [])) in let candidates = candidates @ [ "xdg-open"; "open" ] in ignore @@ -116,7 +101,7 @@ let rec show_job pane job = let dispatch, dispatch_var = Lwt.wait () in let open_editor_asap = ref false in let footer, set_footer = - let display msg = Lwd.map (fun img -> NW.string (img ^ msg)) spinner in + let display msg = Lwd.map ~f:(fun img -> NW.string (img ^ msg)) spinner in let var = Lwd.var (display " Receiving log") in let footer_content = function | `Opening -> display " Opening editor as soon as possible" @@ -134,11 +119,11 @@ let rec show_job pane job = if (not !open_editor_asap) && action = `Activate then ( open_editor_asap := true; set_footer `Opening; - Lwt.ignore_result (Lwt.map (fun fn -> fn `Activate) dispatch) ) + Lwt.ignore_result (Lwt.map (fun fn -> fn `Activate) dispatch)) in Pane.set pane (Some dispatch_fun) - (Lwd.map' footer - (Ui.resize ~sh:1 ~fill:(Gravity.make ~h:`Negative ~v:`Positive))); + (Lwd.map footer + ~f:(Ui.resize ~sh:1 ~pad:(Gravity.make ~h:`Negative ~v:`Positive))); let status = Current_rpc.Job.status job in let start_log = Current_rpc.Job.log ~start:0L job in status @@ -150,25 +135,25 @@ let rec show_job pane job = in let buttons = Lwd.var Ui.empty in [ - ( if can_rebuild then - Some - ( W.button Notty.A.(bg red) "[Rebuild]" @@ fun () -> - Lwd.set buttons Ui.empty; - ignore (show_job pane (Current_rpc.Job.rebuild job)) ) - else None ); - ( if can_cancel then - Some - ( W.button Notty.A.(bg blue) "[Cancel]" @@ fun () -> - Lwd.set buttons Ui.empty; - Lwt.async (fun () -> - Current_rpc.Job.cancel job >>= fun _ -> - ignore (show_job pane job); - Lwt.return_unit) ) - else None ); + (if can_rebuild then + Some + ( W.button Notty.A.(bg red) "[Rebuild]" @@ fun () -> + Lwd.set buttons Ui.empty; + ignore (show_job pane (Current_rpc.Job.rebuild job)) ) + else None); + (if can_cancel then + Some + ( W.button Notty.A.(bg blue) "[Cancel]" @@ fun () -> + Lwd.set buttons Ui.empty; + Lwt.async (fun () -> + Current_rpc.Job.cancel job >>= fun _ -> + ignore (show_job pane job); + Lwt.return_unit) ) + else None); ] |> filter_map (fun x -> x) |> interleave (Ui.atom (Notty.I.void 1 0)) - |> Lwd_utils.pure_pack Ui.pack_x + |> Lwd_utils.reduce Ui.pack_x |> Lwd.set buttons; let log_lines = Lwd_table.make () in Lwt.async (fun () -> @@ -191,7 +176,7 @@ let rec show_job pane job = let description = Lwd.pure (text |> NW.string |> Ui.resize ~w:0 ~sw:1) in let buttons = Lwd.map2 - (fun x y -> Ui.resize ~w:0 ~sw:1 (Ui.join_x x y)) + ~f:(fun x y -> Ui.resize ~w:0 ~sw:1 (Ui.join_x x y)) (Lwd.get buttons) (Lwd.pure (Ui.resize Ui.empty ~h:1 ~sw:1 ~bg:Notty.A.(bg (gray 1)))) in @@ -214,24 +199,25 @@ let rec show_job pane job = in let text_body = W.dynamic_width ~w:0 ~sw:1 ~h:0 ~sh:1 (fun width -> - Lwd.bind width (W.word_wrap_string_table log_lines) + Lwd.bind width ~f:(W.word_wrap_string_table log_lines) |> NW.vscroll_area ~state:(Lwd.get scroll_state) ~change:set_scroll |> (* Scroll when dragging *) Lwd.map - (Ui.mouse_area (fun ~x:_ ~y:y0 -> function - | `Left -> - let st = Lwd.peek scroll_state in - `Grab - ( (fun ~x:_ ~y:y1 -> - let position = st.position + y0 - y1 in - let position = clampi 0 st.bound position in - set_scroll `Change { st with position }), - fun ~x:_ ~y:_ -> () ) - | _ -> `Unhandled))) + ~f: + (Ui.mouse_area (fun ~x:_ ~y:y0 -> function + | `Left -> + let st = Lwd.peek scroll_state in + `Grab + ( (fun ~x:_ ~y:y1 -> + let position = st.position + y0 - y1 in + let position = clampi 0 st.bound position in + set_scroll `Change { st with position }), + fun ~x:_ ~y:_ -> () ) + | _ -> `Unhandled))) in let scroll_bar = Lwd.get scroll_state - |> Lwd.map (fun x -> + |> Lwd.map ~f:(fun x -> x |> W.vertical_scrollbar ~set_scroll:(set_scroll `Change) |> Ui.resize ~w:1 ~sw:0 ~h:0 ~sh:1) @@ -254,7 +240,7 @@ let show_jobs commit pane = Pane.set pane None (Lwd.pure (NW.fmt "%a" Capnp_rpc.Error.pp e)) | Error `No_job -> Pane.set pane None (Lwd.pure (NW.string "No jobs"))) - and render Client.{ variant; outcome } highlight = + and render Client.{ variant; outcome; _ } highlight = Ui.hcat [ render_state highlight outcome; @@ -271,14 +257,14 @@ let show_jobs commit pane = let show_repo repo pane = Client.Repo.refs repo >>= function | Ok refs -> - let select (_, (hash, _status)) = + let select (_, Client.Repo.{ hash; _ }) = let pane = Pane.open_subview pane in Pane.set pane None (Lwd.pure (NW.string "...")); Lwt.async (fun () -> let commit = Client.Repo.commit_of_hash repo hash in show_jobs commit pane) in - let render (gref, (hash, _status)) highlight = + let render (gref, Client.Repo.{ hash; _ }) highlight = render_list_item highlight (Printf.sprintf "%10s #%s" (W.fit_string gref 24) (String.sub hash 0 6)) @@ -292,9 +278,9 @@ let show_repo repo pane = Pane.set pane None (Lwd.pure (NW.fmt "%a" Capnp_rpc.Error.pp e)); Lwt.return_unit -let show_repos pane = +let show_repos pane ~ci_uri = let vat = Capnp_rpc_unix.client_only_vat () in - match import_ci_ref ~vat None with + match import_ci_ref ~vat ci_uri with | Error _ as e -> Lwt.return e | Ok sr -> ( let host = Uri.host_with_default (Capnp_rpc_unix.Vat.export vat sr) in @@ -328,7 +314,7 @@ let show_repos pane = (function | Error e -> [ Error e ] | Ok repos -> - let handle_of { Client.Org.name; master_status = _ } = + let handle_of { Client.Org.name; _ } = Ok ((org, name), Client.Org.repo handle name) in List.map handle_of repos) @@ -338,9 +324,9 @@ let show_repos pane = let items = List.flatten items in let ui, dispatch = W.list_box ~items ~render ~select in Pane.set pane (Some dispatch) ui; - Lwt.return_ok () ) + Lwt.return_ok ()) -let main () = +let main () ci_uri = let pane = Pane.make () in let dispatch pos action = match Pane.current_view pane pos with @@ -350,14 +336,14 @@ let main () = | None -> `Unhandled | Some dispatch -> dispatch action; - `Handled ) + `Handled) in let focus_handle = Focus.make () in Focus.request focus_handle; Lwd.set body - ( Pane.render pane + (Pane.render pane |> Lwd.map2 - (fun focus -> + ~f:(fun focus -> Ui.keyboard_area ~focus @@ function | (`Arrow `Up | `ASCII 'k'), [] -> dispatch `Middle `Select_prev | (`Arrow `Down | `ASCII 'j'), [] -> dispatch `Middle `Select_next @@ -365,9 +351,9 @@ let main () = | (`Arrow `Right | `ASCII 'l'), [] -> dispatch `Right `Activate | (`Escape | `ASCII 'q'), [] -> exit 0 | _ -> `Unhandled) - (Focus.status focus_handle) ); + (Focus.status focus_handle)); Lwt_main.run - (show_repos (Pane.open_root pane) >>= function + (show_repos (Pane.open_root pane) ~ci_uri >>= function | Ok () -> Nottui_lwt.run ui | Error (`Capnp err) -> Format.eprintf "%a" Capnp_rpc.Error.pp err; @@ -376,4 +362,24 @@ let main () = Format.eprintf "Error: %S" msg; Lwt.return_unit) -let () = main () +let setup_log style_renderer level = + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; + Logs.set_reporter (Logs_fmt.reporter ()); + () + +(* Command line interface *) + +open Cmdliner + +let setup_log = + Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ()) + +let cap = + Arg.value + @@ Arg.opt Arg.(some Capnp_rpc_unix.sturdy_uri) None + @@ Arg.info ~doc:"The ocaml-ci.cap file. Defaults to $(i,~/.ocaml-ci.cap)." + ~docv:"CAP" [ "ci-cap" ] + +let main = Term.(const main $ setup_log $ cap) +let () = exit @@ Cmd.(eval (v (info "citty") main)) diff --git a/src/utils.ml b/src/utils.ml index 446a777..b9e4c2c 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -11,6 +11,6 @@ let rec filter_map f = function | x :: xs -> ( match f x with | None -> filter_map f xs - | Some x' -> x' :: filter_map f xs ) + | Some x' -> x' :: filter_map f xs) let update_if_changed v x = if Lwd.peek v <> x then Lwd.set v x diff --git a/src/widgets.ml b/src/widgets.ml index 1e48947..4fd728f 100644 --- a/src/widgets.ml +++ b/src/widgets.ml @@ -41,10 +41,10 @@ let word_wrap_string_table table width = while len - !pos > if !pos > 0 then width - 1 else width do if !pos = 0 then ( lines := (String.sub str !pos (width - 1) ^ "↲") :: !lines; - pos := !pos + (width - 1) ) + pos := !pos + (width - 1)) else ( lines := ("↳" ^ String.sub str !pos (width - 2) ^ "↲") :: !lines; - pos := !pos + (width - 2) ) + pos := !pos + (width - 2)) done; (* Produce an image for one visual line *) @@ -60,7 +60,7 @@ let word_wrap_string_table table width = - concatenate them vertically *) ("↳" ^ String.sub str !pos (len - !pos)) :: lines |> List.rev_map render_line - |> Lwd_utils.pure_pack Ui.pack_y + |> Lwd_utils.reduce Ui.pack_y in (* Stack three images vertically *) let join3 a b c = Ui.join_y a (Ui.join_y b c) in @@ -106,11 +106,9 @@ let word_wrap_string_table table width = | [] -> assert false | suffix :: rest -> let ui = - rest - |> List.rev_map wrap_line - |> Lwd_utils.pure_pack Ui.pack_y + rest |> List.rev_map wrap_line |> Lwd_utils.reduce Ui.pack_y in - (prefix, Some (ui, suffix)) )) + (prefix, Some (ui, suffix)))) ( ("", None), fun (pa, ta) (pb, tb) -> match ta with @@ -119,13 +117,13 @@ let word_wrap_string_table table width = let line = sa ^ pb in ( pa, Some - ( match tb with + (match tb with | None -> (ua, line) - | Some (ub, sb) -> (join3 ua (wrap_line line) ub, sb) ) ) ) + | Some (ub, sb) -> (join3 ua (wrap_line line) ub, sb)) ) ) table |> (* After reducing the table, we produce the final UI, interpreting unterminated prefix and suffix has line of their own. *) - Lwd.map (function + Lwd.map ~f:(function | pa, None -> wrap_line pa | pa, Some (ub, sb) -> join3 (wrap_line pa) ub (wrap_line sb)) @@ -236,10 +234,12 @@ let list_box ~items ~render ~select = let show_item x = let item = (Lwd.var false, x) in let ui = - Lwd.map' (Lwd.get (fst item)) @@ fun highlight -> - Ui.mouse_area - (on_click @@ fun () -> select_item item) - (render (snd item) highlight) + Lwd.map + (Lwd.get (fst item)) + ~f:(fun highlight -> + Ui.mouse_area + (on_click @@ fun () -> select_item item) + (render (snd item) highlight)) in (item, ui) in @@ -260,23 +260,15 @@ let fit_string str len = module Pane : sig type 'a t - type 'a view val make : unit -> 'a t - val render : 'a t -> ui Lwd.t - val current_view : 'a t -> [ `Left | `Middle | `Right ] -> 'a view option - val open_root : 'a t -> 'a view - val open_subview : 'a view -> 'a view - val close_subview : 'a view -> unit - val set : 'a view -> 'a option -> ui Lwd.t -> unit - val get : 'a view -> 'a option end = struct type 'a visual_pane = { @@ -300,9 +292,9 @@ end = struct let bind_pane visual view = visual.view <- view; Lwd.set visual.var - ( match view with + (match view with | None -> empty - | Some view -> Lwd.join (Lwd.get view.content) ) + | Some view -> Lwd.join (Lwd.get view.content)) let make () = let visual () = { var = Lwd.var empty; view = None } in @@ -310,7 +302,7 @@ end = struct let render t = let place_ui_var ?sw v = - Lwd.(v |> get |> join |> map (Ui.resize ~w:0 ?sw)) + Lwd.(v |> get |> join |> map ~f:(Ui.resize ~w:0 ?sw)) in let spacer = Ui.empty |> Ui.resize ~w:1 ~sh:1 ~bg:Notty.A.(bg (gray 1)) |> Lwd.pure @@ -367,8 +359,8 @@ let dynamic_width ?(w = 0) ~sw ?h ?sh f = let width = Lwd.var w in let body = f (Lwd.get width) in body - |> Lwd.map (fun ui -> + |> Lwd.map ~f:(fun ui -> ui |> Ui.resize ~w ~sw ?h ?sh - |> Ui.size_sensor (fun w _ -> + |> Ui.size_sensor (fun ~w ~h:_ -> if Lwd.peek width <> w then Lwd.set width w))