From bb98730832f08a3a02d4cab1099b70463507b255 Mon Sep 17 00:00:00 2001 From: Thibaut Mattio Date: Tue, 5 Jul 2022 16:35:10 +0200 Subject: [PATCH] Fix OCaml 5 compatibility (#110) * Fix OCaml 5 compatibility By removing the compatibility with 4.02.3. The opam dependencies have a constraint on OCaml >= 4.08.0 anyways. * Replace Lwt_log with Logs_lwt * Remove asciiart example which doesn't build on OCaml 5 --- .github/workflows/ci.yml | 2 - README.md | 5 - dune-project | 2 +- dune-workspace.dev | 14 +-- examples/asciiart/asciiart.ml | 215 ---------------------------------- examples/asciiart/dune | 5 - lambda-term.opam | 2 +- src/dune | 2 +- src/lTerm_buttons_impl.ml | 2 - src/lTerm_history.ml | 15 ++- src/lTerm_history.mli | 2 +- src/lTerm_key.ml | 7 -- src/lTerm_widget_callbacks.ml | 8 +- 13 files changed, 25 insertions(+), 256 deletions(-) delete mode 100644 examples/asciiart/asciiart.ml delete mode 100644 examples/asciiart/dune diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 120f8721..8c0c291c 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -34,8 +34,6 @@ jobs: - run: opam install . --deps-only --with-test - - run: opam install camlimages - - run: opam exec -- dune build - run: opam exec -- dune runtest diff --git a/README.md b/README.md index e288765a..8139b65c 100644 --- a/README.md +++ b/README.md @@ -56,11 +56,6 @@ To build the examples: Binaries for the examples will be in `_build/default/examples`. -The `asciiart` example is not built by default as it as an additional -dependency on the `camlimages` library. To build it run: - - $ dune build examples/asciiart/asciiart.exe - Terminal emulators compatibility -------------------------------- diff --git a/dune-project b/dune-project index 317caef7..7a7a177b 100644 --- a/dune-project +++ b/dune-project @@ -28,9 +28,9 @@ facilities in console applications.") (depends (ocaml (>= 4.08.0)) + logs (lwt (>= 4.2.0)) - lwt_log lwt_react (mew_vi (and diff --git a/dune-workspace.dev b/dune-workspace.dev index 57c7e08d..d4d3bf0a 100644 --- a/dune-workspace.dev +++ b/dune-workspace.dev @@ -1,10 +1,10 @@ (lang dune 1.1) ;; This file is used by `make all-supported-ocaml-versions` -(context (opam (switch 4.02.3))) -(context (opam (switch 4.03.0))) -(context (opam (switch 4.04.2))) -(context (opam (switch 4.05.0))) -(context (opam (switch 4.06.1))) -(context (opam (switch 4.07.0))) - +(context (opam (switch 4.08.1))) +(context (opam (switch 4.09.1))) +(context (opam (switch 4.10.2))) +(context (opam (switch 4.11.2))) +(context (opam (switch 4.12.1))) +(context (opam (switch 4.13.1))) +(context (opam (switch 4.14.0))) diff --git a/examples/asciiart/asciiart.ml b/examples/asciiart/asciiart.ml deleted file mode 100644 index a326e80b..00000000 --- a/examples/asciiart/asciiart.ml +++ /dev/null @@ -1,215 +0,0 @@ -(* - * asciiart.ml - * ----------- - * Copyright : (c) 2016, Andy Ray - * Licence : BSD3 - * - * This file is a part of Lambda-Term. - *) - -(* ascii chars of increasing intensity *) -let palette = " .*:o&8#@" - -(* grayscale conversion coefficients *) -let coefs = [| 0.229; 0.587; 0.114 |] - -(* load image *) -let load file = - let img = OImages.load file [] in - match OImages.tag img with - | OImages.Index8 img - | OImages.Index16 img -> img#to_rgb24 - | OImages.Rgb24 img -> img - | _ -> failwith "not supported" - -(* images will be scaled down by averaging pixels in blocks of this size *) -let avg_cols = ref 5 -let avg_rows = ref 10 - -let filename = ref "test.png" - -let () = Arg.(parse [ - "-cols", Set_int avg_cols, "num cols to average"; - "-rows", Set_int avg_rows, "num rows to average"; -] (fun s -> filename := s) "asciiart [options] filename") - -(* scale image and convert to indices into palette *) -let indices img = - let rows = img#height in - let cols = img#width in - let avg = float_of_int (!avg_rows * !avg_cols) in - let luma r g b = - ((float_of_int r *. coefs.(0)) +. - (float_of_int g *. coefs.(1)) +. - (float_of_int b *. coefs.(2))) - in - Array.init (rows / !avg_rows) (fun row -> - Array.init (cols / !avg_cols) (fun col -> - let sum = ref 0. in - for row=row * !avg_rows to ((row+1) * !avg_rows)-1 do - for col=col * !avg_cols to ((col+1) * !avg_cols)-1 do - let pel = img#get col row in - sum := !sum +. (luma pel.Images.r pel.Images.g pel.Images.b) - done - done; - let sum = !sum /. (256. *. avg) in - max 0 @@ min 8 (int_of_float (sum *. 9.)))) - -open Lwt -open LTerm_widget -open LTerm_geom - -(* scrollable asciiart widget *) -class asciiart img = object(self) - inherit t "asciiart" as super - - method! can_focus = true - - (* scrollable interfaces *) - val vscroll = new scrollable - val hscroll = new scrollable - method vscroll = vscroll - method hscroll = hscroll - - method document_size = { - rows = img#height / !avg_rows; - cols = img#width / !avg_cols; - } - - initializer - vscroll#set_document_size self#document_size.rows; - hscroll#set_document_size self#document_size.cols - - method! set_allocation r = - super#set_allocation r; - let size = size_of_rect r in - vscroll#set_page_size size.rows; - hscroll#set_page_size size.cols - - val style = - LTerm_style.({ none with foreground=Some white; - background=Some black }) - - (* buffer the image - reconvert when the scale changes *) - val mutable stored_img : (int * int * (int array array)) option = None - method img = - match stored_img with - | Some(r, c, i) when r = !avg_rows && c = !avg_cols -> i - | _ -> stored_img <- Some(!avg_rows, !avg_cols, indices img); self#img - - method! draw ctx _focused = - let { rows; cols } = LTerm_draw.size ctx in - let img = self#img in - for row=0 to rows-1 do - for col=0 to cols-1 do - LTerm_draw.draw_char ~style ctx row col @@ - Zed_char.unsafe_of_char palette.[ - try img.(row + vscroll#offset).(col + hscroll#offset) with _ -> 0 - ] - done - done - - (* delta from center of screen *) - method private mouse_delta_event ev = - let open LTerm_mouse in - match ev with - | LTerm_event.Mouse m when m.button=Button1 && m.control=true -> - let alloc = self#allocation in - let size = size_of_rect alloc in - vscroll#set_offset - (vscroll#offset + m.LTerm_mouse.row - alloc.row1 - size.rows/2); - hscroll#set_offset - (hscroll#offset + m.LTerm_mouse.col - alloc.col1 - size.cols/2); - true - | _ -> false - - (* adjust scale, which changes the document size *) - method private scale_event = function - | LTerm_event.Key{LTerm_key.code=LTerm_key.Char c;_} when c = Uchar.of_char 'w' -> - avg_rows := max 1 (!avg_rows - 1); - vscroll#set_document_size self#document_size.rows; - self#queue_draw; true - | LTerm_event.Key{LTerm_key.code=LTerm_key.Char c;_} when c = Uchar.of_char 's' -> - avg_rows := !avg_rows + 1; - vscroll#set_document_size self#document_size.rows; - self#queue_draw; true - | LTerm_event.Key{LTerm_key.code=LTerm_key.Char c;_} when c = Uchar.of_char 'a' -> - avg_cols := max 1 (!avg_cols - 1); - hscroll#set_document_size self#document_size.cols; - self#queue_draw; true - | LTerm_event.Key{LTerm_key.code=LTerm_key.Char c;_} when c = Uchar.of_char 'd' -> - avg_cols := !avg_cols + 1; - hscroll#set_document_size self#document_size.cols; - self#queue_draw; true - | _ -> false - - (* page up/down *) - method page_event = function - | LTerm_event.Key{LTerm_key.code=LTerm_key.Next_page;_} -> - vscroll#set_offset @@ vscroll#page_next; self#queue_draw; true - | LTerm_event.Key{LTerm_key.code=LTerm_key.Prev_page;_} -> - vscroll#set_offset @@ vscroll#page_prev; self#queue_draw; true - | _ -> false - - initializer - self#on_event (fun ev -> self#scale_event ev || - self#page_event ev || - self#mouse_delta_event ev) - -end - -(* place vertical and horizontal scroll bars around the picture *) -let with_scrollbar ?down widget = - let vbox = new vbox in - let hbox = new hbox in - (* make scroll bars roughly the same size *) - let vscroll = new vscrollbar ~width:3 widget#vscroll in - let hscroll = new hscrollbar ~height:2 widget#hscroll in - let spacing = new spacing ~rows:2 ~cols:3 () in - hbox#add widget; - hbox#add ~expand:false (new vline); - hbox#add ~expand:false vscroll; - vbox#add hbox; - vbox#add ~expand:false (new hline); - let hbox = new hbox in - hbox#add hscroll; - hbox#add ~expand:false (new vline); - hbox#add ~expand:false spacing; - vbox#add ~expand:false hbox; - (* moving focus *) - widget#set_focus { widget#focus with right = Some(vscroll :> t); - down = Some(hscroll :> t) }; - vscroll#set_focus { vscroll#focus with down = Some(hscroll :> t) }; - hscroll#set_focus { hscroll#focus with up = Some(vscroll :> t); down }; - (* events *) - widget#on_event (fun ev -> vscroll#mouse_event ev && hscroll#mouse_event ev); - vscroll#on_event widget#page_event; - vbox - -let main () = - let img = load !filename in - - let waiter, wakener = wait () in - let exit = new button "exit" in - exit#on_click (wakeup wakener); - - let vbox = with_scrollbar ~down:(exit :> t) (new asciiart img) in - vbox#add ~expand:false (new hline); - vbox#add ~expand:false exit; - - let top = new frame in - top#set vbox; - - top#on_event (function (* quit with escape key *) - | LTerm_event.Key{LTerm_key.code=LTerm_key.Escape;_} -> - wakeup wakener (); false - | _ -> false); - - Lazy.force LTerm.stdout >>= fun term -> - LTerm.enable_mouse term >>= fun () -> - Lwt.finalize - (fun () -> run term top waiter) - (fun () -> LTerm.disable_mouse term) - -let () = Lwt_main.run (main ()) - diff --git a/examples/asciiart/dune b/examples/asciiart/dune deleted file mode 100644 index 66d18b60..00000000 --- a/examples/asciiart/dune +++ /dev/null @@ -1,5 +0,0 @@ -(executable - (name asciiart) - (libraries lambda-term - camlimages.png - camlimages.jpeg)) diff --git a/lambda-term.opam b/lambda-term.opam index 3d9a93cf..572f1808 100644 --- a/lambda-term.opam +++ b/lambda-term.opam @@ -18,8 +18,8 @@ bug-reports: "https://github.com/ocaml-community/lambda-term/issues" depends: [ "dune" {>= "3.0"} "ocaml" {>= "4.08.0"} + "logs" "lwt" {>= "4.2.0"} - "lwt_log" "lwt_react" "mew_vi" {>= "0.5.0" & < "0.6.0"} "react" diff --git a/src/dune b/src/dune index 7cf22944..82edd292 100644 --- a/src/dune +++ b/src/dune @@ -2,7 +2,7 @@ (name lambda_term) (public_name lambda-term) (wrapped false) - (libraries lwt lwt.unix lwt_react zed lwt_log mew_vi uucp) + (libraries logs logs.lwt lwt lwt.unix lwt_react zed mew_vi uucp) (flags (:standard -safe-string)) (synopsis "Cross-platform library for terminal manipulation") (c_library_flags (:standard (:include c_library_flags))) diff --git a/src/lTerm_buttons_impl.ml b/src/lTerm_buttons_impl.ml index 1c2ca61b..9dc6baed 100644 --- a/src/lTerm_buttons_impl.ml +++ b/src/lTerm_buttons_impl.ml @@ -13,8 +13,6 @@ module Make (LiteralIntf: LiteralIntf.Type) = struct open LTerm_mouse open LTerm_widget_callbacks - let section = Lwt_log.Section.make "lambda-term(buttons_impl)" - class t = LTerm_widget_base_impl.t let space = Char(Uchar.of_char ' ') diff --git a/src/lTerm_history.ml b/src/lTerm_history.ml index f4ed7964..a9fa45ef 100644 --- a/src/lTerm_history.ml +++ b/src/lTerm_history.ml @@ -321,7 +321,9 @@ let unescape line = in loop 0 0 -let section = Lwt_log.Section.make "lambda-term(history)" + +let src = Logs.Src.create "lambda-term.history" ~doc:"logs LTerm_history module's events" +module Log = (val Logs_lwt.src_log src : Logs_lwt.LOG) let rec safe_lockf fn fd cmd ofs = Lwt.catch (fun () -> @@ -331,7 +333,7 @@ let rec safe_lockf fn fd cmd ofs = | Unix.Unix_error (Unix.EINTR, _, _) -> safe_lockf fn fd cmd ofs | Unix.Unix_error (error, _, _) -> - Lwt_log.ign_warning_f ~section "failed to lock file '%s': %s" fn (Unix.error_message error); + Log.warn (fun m -> m "failed to lock file '%s': %s" fn (Unix.error_message error)) >>= fun () -> return false | exn -> Lwt.fail exn) @@ -344,7 +346,7 @@ let open_history fn = | Unix.Unix_error (Unix.ENOENT, _, _) -> return None | Unix.Unix_error (Unix.EACCES, _, _) -> - Lwt_log.ign_info_f "cannot open file '%s' in read and write mode: %s" fn (Unix.error_message Unix.EACCES); + Log.info (fun m -> m "cannot open file '%s' in read and write mode: %s" fn (Unix.error_message Unix.EACCES)) >>= fun () -> (* If the file cannot be openned in read & write mode, open it in read only mode but do not lock it. *) Lwt.catch (fun () -> @@ -369,7 +371,7 @@ let load history ?log ?(skip_empty=true) ?(skip_dup=true) fn = func | None -> fun line msg -> - Lwt_log.ign_error_f ~section "File %S, at line %d: %s" fn line msg + Log.info (fun m -> m "File %S, at line %d: %s" fn line msg) in (* File opening. *) open_history fn >>= fun history_file -> @@ -392,11 +394,12 @@ let load history ?log ?(skip_empty=true) ?(skip_dup=true) fn = if not (skip_empty && is_empty entry) && not (skip_dup && is_dup history entry) then begin add_aux history entry size; history.old_count <- history.length - end + end; + Lwt.return () with | Zed_string.Invalid (msg, _)-> log num msg | Zed_utf8.Invalid (msg, _)-> log num msg - ); + ) >>= fun () -> aux (num + 1) in aux 1) diff --git a/src/lTerm_history.mli b/src/lTerm_history.mli index 24885ee6..a3631695 100644 --- a/src/lTerm_history.mli +++ b/src/lTerm_history.mli @@ -72,7 +72,7 @@ val set_max_entries : t -> int -> unit oldest entries to honor the new limit. *) val load : t -> - ?log : (int -> string -> unit) -> + ?log : (int -> string -> unit Lwt.t) -> ?skip_empty : bool -> ?skip_dup : bool -> string -> unit Lwt.t diff --git a/src/lTerm_key.ml b/src/lTerm_key.ml index e7f37382..7ab5b045 100644 --- a/src/lTerm_key.ml +++ b/src/lTerm_key.ml @@ -7,13 +7,6 @@ * This file is a part of Lambda-Term. *) -(* little hack to maintain 4.02.3 compat with warnings *) -module String = struct - [@@@ocaml.warning "-3-32"] - let lowercase_ascii = StringLabels.lowercase - include String -end - type code = | Char of Uchar.t | Enter diff --git a/src/lTerm_widget_callbacks.ml b/src/lTerm_widget_callbacks.ml index 4d8dc721..22fa8929 100644 --- a/src/lTerm_widget_callbacks.ml +++ b/src/lTerm_widget_callbacks.ml @@ -7,7 +7,8 @@ * This file is a part of Lambda-Term. *) -let section = Lwt_log.Section.make "lambda-term(widget_callbacks)" +let src = Logs.Src.create "lambda-term.widget-callbacks" ~doc:"logs LTerm_widget_callbacks module's events" +module Log = (val Logs.src_log src : Logs.LOG) (* +-----------------------------------------------------------------+ | Callbacks | @@ -44,7 +45,8 @@ let exec_callbacks seq x = try f x with exn -> - ignore (Lwt_log.error ~section ~exn "callback failed with")) + Log.err (fun m -> m "callback failed with %s" (Printexc.to_string exn)); + ()) seq let exec_filters seq x = @@ -56,7 +58,7 @@ let exec_filters seq x = try f x with exn -> - ignore (Lwt_log.error ~section ~exn "filter failed with"); + Log.err (fun m -> m "filter failed with %s" (Printexc.to_string exn)); false end) seq false