From c2c8376f3e33d58c1b4da06f20636bfc91cc0769 Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Thu, 13 Aug 2020 15:11:59 +0200 Subject: [PATCH 1/3] Fix FTBFS with OCaml 4.08.1 Bug-Debian: https://bugs.debian.org/956556 --- deb_lib.mli | 2 +- ptset.ml | 34 +++++++++++++++ ptset.mli | 116 ++++++++++++++++++------------------------------- repository.ml | 2 +- repository.mli | 2 +- task.ml | 5 ++- util.mli | 2 +- 7 files changed, 84 insertions(+), 79 deletions(-) diff --git a/deb_lib.mli b/deb_lib.mli index f52af99..f27b43d 100644 --- a/deb_lib.mli +++ b/deb_lib.mli @@ -68,7 +68,7 @@ module PkgDenseTbl : sig val remove : 'a t -> package_name -> unit val iteri : (package_name -> 'a -> unit) -> 'a t -> unit end -module PkgSet : Set.S with type elt = package_name +module PkgSet : Ptset.SET_SIG with type elt = package_name val find_package_by_num : pool -> int -> p val find_packages_by_name : pool -> package_name -> p list diff --git a/ptset.ml b/ptset.ml index 91e8e35..5d86632 100644 --- a/ptset.ml +++ b/ptset.ml @@ -15,6 +15,40 @@ (*i $Id: ptset.ml,v 1.17 2008-07-22 06:44:06 filliatr Exp $ i*) +(*s Restricted Set.S signature *) + +module type SET_SIG = sig + type elt + type t + val empty : t + val is_empty : t -> bool + val mem : elt -> t -> bool + val find : elt -> t -> int + val add : elt -> t -> t + val of_list : elt list -> t + val singleton : elt -> t + val remove : elt -> t -> t + val union : t -> t -> t + val subset : t -> t -> bool + val inter : t -> t -> t + val diff : t -> t -> t + val equal : t -> t -> bool + val compare : t -> t -> int + val elements : t -> elt list + val choose : t -> elt + val cardinal : t -> int + val iter : (elt -> unit) -> t -> unit + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val for_all : (elt -> bool) -> t -> bool + val exists : (elt -> bool) -> t -> bool + val filter : (elt -> bool) -> t -> t + val partition : (elt -> bool) -> t -> t * t + val split : elt -> t -> t * bool * t + val min_elt : t -> int + val max_elt : t -> int + val intersect : t -> t -> bool +end + (*s Sets of integers implemented as Patricia trees, following Chris Okasaki and Andrew Gill's paper {\em Fast Mergeable Integer Maps} ({\tt\small http://www.cs.columbia.edu/\~{}cdo/papers.html\#ml98maps}). diff --git a/ptset.mli b/ptset.mli index 9b5323a..34778a7 100644 --- a/ptset.mli +++ b/ptset.mli @@ -15,6 +15,46 @@ (*i $Id: ptset.mli,v 1.10 2008-07-21 14:53:06 filliatr Exp $ i*) +(*s Restricted Set.S signature *) + +module type SET_SIG = sig + type elt + type t + val empty : t + val is_empty : t -> bool + val mem : elt -> t -> bool + val find : elt -> t -> int + val add : elt -> t -> t + val of_list : elt list -> t + val singleton : elt -> t + val remove : elt -> t -> t + val union : t -> t -> t + val subset : t -> t -> bool + val inter : t -> t -> t + val diff : t -> t -> t + val equal : t -> t -> bool + val compare : t -> t -> int + val elements : t -> elt list + val choose : t -> elt + val cardinal : t -> int + val iter : (elt -> unit) -> t -> unit + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val for_all : (elt -> bool) -> t -> bool + val exists : (elt -> bool) -> t -> bool + val filter : (elt -> bool) -> t -> t + val partition : (elt -> bool) -> t -> t * t + val split : elt -> t -> t * bool * t + val min_elt : t -> int + val max_elt : t -> int + + (*s Additional functions not appearing in the signature [Set.S] from ocaml + standard library. *) + + (* [intersect u v] determines if sets [u] and [v] have a non-empty + intersection. *) + val intersect : t -> t -> bool +end + (*s Sets of integers implemented as Patricia trees. The following signature is exactly [Set.S with type elt = int], with the same specifications. This is a purely functional data-structure. The @@ -22,80 +62,15 @@ [Set]. The representation is unique and thus structural comparison can be performed on Patricia trees. *) -type t - -type elt = int - -val empty : t - -val is_empty : t -> bool - -val mem : int -> t -> bool - -val find : int -> t -> int - -val add : int -> t -> t - -val of_list : elt list -> t - -val singleton : int -> t - -val remove : int -> t -> t - -val union : t -> t -> t - -val subset : t -> t -> bool - -val inter : t -> t -> t - -val diff : t -> t -> t - -val equal : t -> t -> bool - -val compare : t -> t -> int - -val elements : t -> int list - -val choose : t -> int - -val cardinal : t -> int - -val iter : (int -> unit) -> t -> unit - -val fold : (int -> 'a -> 'a) -> t -> 'a -> 'a - -val for_all : (int -> bool) -> t -> bool - -val exists : (int -> bool) -> t -> bool - -val filter : (int -> bool) -> t -> t - -val partition : (int -> bool) -> t -> t * t - -val split : int -> t -> t * bool * t +include SET_SIG with type elt = int (*s Warning: [min_elt] and [max_elt] are linear w.r.t. the size of the set. In other words, [min_elt t] is barely more efficient than [fold min t (choose t)]. *) -val min_elt : t -> int -val max_elt : t -> int - -(*s Additional functions not appearing in the signature [Set.S] from ocaml - standard library. *) - -(* [intersect u v] determines if sets [u] and [v] have a non-empty - intersection. *) - -val intersect : t -> t -> bool - - (*s Big-endian Patricia trees *) -module Big : sig - include Set.S with type elt = int - val intersect : t -> t -> bool -end +module Big : SET_SIG with type elt = int (*s Big-endian Patricia trees with non-negative elements. Changes: @@ -105,9 +80,4 @@ end - [elements] returns a list with elements in ascending order *) -module BigPos : sig - include Set.S with type elt = int - val intersect : t -> t -> bool -end - - +module BigPos : SET_SIG with type elt = int diff --git a/repository.ml b/repository.ml index fbf214d..d98c89e 100644 --- a/repository.ml +++ b/repository.ml @@ -30,7 +30,7 @@ module type S = sig val of_index_list : int list -> t list end - module PSet : Set.S with type elt = Package.t + module PSet : Ptset.SET_SIG with type elt = Package.t module PMap : Map.S with type key = Package.t val pset_indices : PSet.t -> Util.IntSet.t diff --git a/repository.mli b/repository.mli index 46ef8ac..c217154 100644 --- a/repository.mli +++ b/repository.mli @@ -30,7 +30,7 @@ module type S = sig val of_index_list : int list -> t list end - module PSet : Set.S with type elt = Package.t + module PSet : Ptset.SET_SIG with type elt = Package.t module PMap : Map.S with type key = Package.t val pset_indices : PSet.t -> Util.IntSet.t diff --git a/task.ml b/task.ml index a4a1857..4305ee8 100644 --- a/task.ml +++ b/task.ml @@ -113,8 +113,9 @@ let spawn f = let (sr, cw) = Unix.pipe () in let fd = Unix.openfile "/dev/zero" [Unix.O_RDWR] 0 in let mem = - Bigarray.Array1.map_file - fd Bigarray.char Bigarray.c_layout true mem_size + Unix.map_file + fd Bigarray.char Bigarray.c_layout true [|mem_size|] + |> Bigarray.array1_of_genarray in Unix.close fd; match Unix.fork () with diff --git a/util.mli b/util.mli index ad0bb9c..56fff35 100644 --- a/util.mli +++ b/util.mli @@ -43,7 +43,7 @@ module Utimer : sig val stop : t -> float end -module IntSet : Set.S with type elt = int +module IntSet : Ptset.SET_SIG with type elt = int module StringSet : Set.S with type elt = string module ListTbl : sig From 764e04946de68daa4860ed5baac75c1c9a0fc824 Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Tue, 18 Aug 2020 13:22:13 +0200 Subject: [PATCH 2/3] Port to modern js_of_ocaml --- viewer/Makefile | 6 +- viewer/viewer_js.ml | 155 ++++++++++++++++++++++---------------------- 2 files changed, 82 insertions(+), 79 deletions(-) diff --git a/viewer/Makefile b/viewer/Makefile index 5153664..437799a 100644 --- a/viewer/Makefile +++ b/viewer/Makefile @@ -5,7 +5,7 @@ OCAMLDEP=ocamlfind ocamldep OCAMLYACC=ocamlyacc OCAMLLEX=ocamllex -COMPFLAGS=-package str,cairo.lablgtk2,js_of_ocaml,js_of_ocaml.syntax -syntax camlp4o +COMPFLAGS=-package str,cairo.lablgtk2,js_of_ocaml,js_of_ocaml-ppx,js_of_ocaml-lwt DEPFLAGS=$(COMPFLAGS) GENERATED=dot_parser.ml dot_lexer.ml @@ -18,7 +18,7 @@ CONVERTER=scene.cmx scene_extents.cmx scene_json.cmx \ OPTLINKFLAGS=-package str,cairo.lablgtk2 -linkpkg JSOBJS=scene.cmo viewer_common.cmo viewer_js.cmo -LINKFLAGS=-package js_of_ocaml -linkpkg +LINKFLAGS=-package js_of_ocaml,js_of_ocaml-lwt -linkpkg all: coinst_viewer jsviewer.js coinst_converter opt: all @@ -37,7 +37,7 @@ coinst_converter.byte: $(CONVERTER:.cmx=.cmo) $(OCAMLC) -o $@ $(OPTLINKFLAGS) $^ jsviewer.js: jsviewer.byte - js_of_ocaml $^ -pretty + js_of_ocaml $^ --pretty jsviewer.byte: $(JSOBJS) $(OCAMLC) -o $@ $(LINKFLAGS) $^ diff --git a/viewer/viewer_js.ml b/viewer/viewer_js.ml index a8cdd99..72541b3 100644 --- a/viewer/viewer_js.ml +++ b/viewer/viewer_js.ml @@ -17,13 +17,16 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Js_of_ocaml +open Js_of_ocaml_lwt + type rect = {x : int; y : int; width : int; height: int} module Html = Dom_html let create_canvas w h = let c = Html.createCanvas Html.document in - c##width <- w; c##height <- h; c + c##.width := w; c##.height := h; c module Common = Viewer_common.F (struct type font = Js.js_string Js.t @@ -33,38 +36,38 @@ module Common = Viewer_common.F (struct type ctx = Html.canvasRenderingContext2D Js.t - let save ctx = ctx##save () - let restore ctx = ctx##restore () + let save ctx = ctx##save + let restore ctx = ctx##restore - let scale ctx ~sx ~sy = ctx##scale (sx, sy) - let translate ctx ~tx ~ty = ctx##translate (tx, ty) + let scale ctx ~sx ~sy = ctx##scale sx sy + let translate ctx ~tx ~ty = ctx##translate tx ty - let set_line_width ctx w = ctx##lineWidth <- w + let set_line_width ctx w = ctx##.lineWidth := w - let begin_path ctx = ctx##beginPath () - let close_path ctx = ctx##closePath () - let move_to ctx ~x ~y = ctx##moveTo (x, y) - let line_to ctx ~x ~y = ctx##lineTo (x, y) + let begin_path ctx = ctx##beginPath + let close_path ctx = ctx##closePath + let move_to ctx ~x ~y = ctx##moveTo x y + let line_to ctx ~x ~y = ctx##lineTo x y let curve_to ctx ~x1 ~y1 ~x2 ~y2 ~x3 ~y3 = - ctx##bezierCurveTo (x1, y1, x2, y2, x3, y3) + ctx##bezierCurveTo x1 y1 x2 y2 x3 y3 let arc ctx ~xc ~yc ~radius ~angle1 ~angle2 = - ctx##arc (xc, yc, radius, angle1, angle2, Js._true) - let rectangle ctx ~x ~y ~width ~height = ctx##rect (x, y, width, height) + ctx##arc xc yc radius angle1 angle2 Js._true + let rectangle ctx ~x ~y ~width ~height = ctx##rect x y width height - let fill ctx c = ctx##fillStyle <- c; ctx##fill () - let stroke ctx c = ctx##strokeStyle <- c; ctx##stroke () - let clip ctx = ctx##clip () + let fill ctx c = ctx##.fillStyle := c; ctx##fill + let stroke ctx c = ctx##.strokeStyle := c; ctx##stroke + let clip ctx = ctx##clip let draw_text (ctx:ctx) x y txt font fill_color stroke_color = - ctx##font <- font; - ctx##textAlign <- Js.string "center"; - ctx##textBaseline <- Js.string "middle"; + ctx##.font := font; + ctx##.textAlign := Js.string "center"; + ctx##.textBaseline := Js.string "middle"; begin match fill_color with - Some c -> ctx##fillStyle <- c; ctx##fillText (txt, x, y) + Some c -> ctx##.fillStyle := c; ctx##fillText txt x y | None -> () end; begin match stroke_color with - Some c -> ctx##strokeStyle <- c; ctx##strokeText (txt, x, y) + Some c -> ctx##.strokeStyle := c; ctx##strokeText txt x y | None -> () end @@ -73,16 +76,16 @@ module Common = Viewer_common.F (struct type pixmap = drawable let get_drawable w = let ctx = w##getContext(Html._2d_) in - ctx##lineWidth <- 2.; + ctx##.lineWidth := 2.; (w, ctx) let make_pixmap _ width height = let c = Html.createCanvas Html.document in - c##width <- width; c##height <- height; + c##.width := width; c##.height := height; get_drawable c let drawable_of_pixmap p = p let get_context (p, c) = c let put_pixmap ~dst:((p, c) :drawable) ~x ~y ~xsrc ~ysrc ~width ~height ((p, _) : pixmap)= - c##drawImage_fullFromCanvas (p, float xsrc, float ysrc, float width, float height, float x, float y, float width, float height) + c##drawImage_fullFromCanvas p (float xsrc) (float ysrc) (float width) (float height) (float x) (float y) (float width) (float height) (****) @@ -92,8 +95,8 @@ end) open Common let redraw st s h v (canvas : Html.canvasElement Js.t) = - let width = canvas##width in - let height = canvas##height in + let width = canvas##.width in + let height = canvas##.height in (*Firebug.console##time (Js.string "draw");*) if width > 0 && height > 0 then redraw st s h v canvas @@ -141,15 +144,15 @@ class adjustment let handle_drag element f = let mx = ref 0 in let my = ref 0 in - element##onmousedown <- Html.handler + element##.onmousedown := Html.handler (fun ev -> - mx := ev##clientX; my := ev##clientY; - element##style##cursor <- Js.string "move"; + mx := ev##.clientX; my := ev##.clientY; + element##.style##.cursor := Js.string "move"; let c1 = Html.addEventListener Html.document Html.Event.mousemove (Html.handler (fun ev -> - let x = ev##clientX and y = ev##clientY in + let x = ev##.clientX and y = ev##.clientY in let x' = !mx and y' = !my in mx := x; my := y; f (x - x') (y - y'); @@ -165,7 +168,7 @@ let handle_drag element f = Js.Opt.iter !c2 Html.removeEventListener; (* "auto" would be better, but does not seem to work with Opera *) - element##style##cursor <- Js.string ""; + element##.style##.cursor := Js.string ""; Js._true)) Js._true); (* We do not want to disable the default action on mouse down @@ -181,19 +184,19 @@ let load () = let start () = let doc = Html.document in - let page = doc##documentElement in - page##style##overflow <- Js.string "hidden"; - doc##body##style##overflow <- Js.string "hidden"; - doc##body##style##margin <- Js.string "0px"; + let page = doc##.documentElement in + page##.style##.overflow := Js.string "hidden"; + doc##.body##.style##.overflow := Js.string "hidden"; + doc##.body##.style##.margin := Js.string "0px"; let started = ref false in let p = Html.createP doc in - p##innerHTML <- Js.string "Loading graph..."; - p##style##display <- Js.string "none"; - Dom.appendChild doc##body p; + p##.innerHTML := Js.string "Loading graph..."; + p##.style##.display := Js.string "none"; + Dom.appendChild doc##.body p; ignore (Lwt_js.sleep 0.5 >>= fun () -> - if not !started then p##style##display <- Js.string "inline"; + if not !started then p##.style##.display := Js.string "inline"; Lwt.return ()); (* @@ -206,7 +209,7 @@ let start () = *) started := true; - Dom.removeChild doc##body p; + Dom.removeChild doc##.body p; let st = { bboxes = bboxes; @@ -216,10 +219,10 @@ let start () = st_pixmap = Common.make_pixmap () } in - let canvas = create_canvas (page##clientWidth) (page##clientHeight) in - Dom.appendChild doc##body canvas; + let canvas = create_canvas (page##.clientWidth) (page##.clientHeight) in + Dom.appendChild doc##.body canvas; let allocation () = - {x = 0; y = 0; width = canvas##width; height = canvas##height} in + {x = 0; y = 0; width = canvas##.width; height = canvas##.height} in let hadj = new adjustment () in let vadj = new adjustment () in @@ -299,28 +302,28 @@ Firebug.console##log(Js.string "sleep"); let size_px = points size in let pos = ref height in let thumb = Html.createDiv doc in - let style = thumb##style in - style##position <- Js.string "absolute"; - style##width <- size_px; - style##height <- size_px; - style##top <- points !pos; - style##left <- Js.string "0px"; - style##margin <- Js.string "1px"; - style##backgroundColor <- Js.string "black"; + let style = thumb##.style in + style##.position := Js.string "absolute"; + style##.width := size_px; + style##.height := size_px; + style##.top := points !pos; + style##.left := Js.string "0px"; + style##.margin := Js.string "1px"; + style##.backgroundColor := Js.string "black"; let slider = Html.createDiv doc in - let style = slider##style in - style##position <- Js.string "absolute"; - style##width <- size_px; - style##height <- points (height + size); - style##border <- Js.string "2px solid black"; - style##padding <- Js.string "1px"; - style##top <- Js.string "10px"; - style##left <- Js.string "10px"; + let style = slider##.style in + style##.position := Js.string "absolute"; + style##.width := size_px; + style##.height := points (height + size); + style##.border := Js.string "2px solid black"; + style##.padding := Js.string "1px"; + style##.top := Js.string "10px"; + style##.left := Js.string "10px"; Dom.appendChild slider thumb; - Dom.appendChild doc##body slider; + Dom.appendChild doc##.body slider; let set_slider_position pos' = if pos' <> !pos then begin - thumb##style##top <- points pos'; + thumb##.style##.top := points pos'; pos := pos'; sadj#set_value (float (height - pos') *. sadj#upper /. float height); rescale 0.5 0.5 @@ -329,24 +332,24 @@ Firebug.console##log(Js.string "sleep"); handle_drag thumb (fun dx dy -> set_slider_position (min height (max 0 (!pos + dy)))); - slider##onmousedown <- Html.handler + slider##.onmousedown := Html.handler (fun ev -> - let ey = ev##clientY in + let ey = ev##.clientY in let (_, sy) = Dom_html.elementClientPosition slider in set_slider_position (max 0 (min height (ey - sy - size / 2))); Js._false); let adjust_slider () = let pos' = height - truncate (sadj#value *. float height /. sadj#upper +. 0.5) in - thumb##style##top <- points pos'; + thumb##.style##.top := points pos'; pos := pos' in - Html.window##onresize <- Html.handler + Html.window##.onresize := Html.handler (fun _ -> - let page = doc##documentElement in - canvas##width <- page##clientWidth; - canvas##height <- page##clientHeight; + let page = doc##.documentElement in + canvas##.width := page##.clientWidth; + canvas##.height := page##.clientHeight; update_view true; Js._true); @@ -383,8 +386,8 @@ Firebug.console##log(Js.string "sleep"); ignore (Html.addMousewheelEventListener canvas (fun ev ~dx ~dy -> let (ex, ey) = Dom_html.elementClientPosition canvas in - let x = float (ev##clientX - ex) in - let y = float (ev##clientY - ey) in + let x = float (ev##.clientX - ex) in + let y = float (ev##.clientY - ey) in if dy < 0 then bump_scale x y 1. else if dy > 0 then @@ -420,7 +423,7 @@ Firebug.console##log(Js.string "sleep"); Js._true; *) let handle_key_event ev = - match ev##keyCode with + match ev##.keyCode with 37 -> (* left *) hadj#set_value (hadj#value -. hadj#step_increment); update_view false; @@ -444,17 +447,17 @@ Firebug.console##log(Js.string "sleep"); Js._true in let ignored_keycode = ref (-1) in - Html.document##onkeydown <- + Html.document##.onkeydown := (Html.handler (fun e -> - ignored_keycode := e##keyCode; + ignored_keycode := e##.keyCode; handle_key_event e)); - Html.document##onkeypress <- + Html.document##.onkeypress := (Html.handler (fun e -> let k = !ignored_keycode in ignored_keycode := -1; - if e##keyCode = k then Js._true else handle_key_event e)); + if e##.keyCode = k then Js._true else handle_key_event e)); (* @@ -469,4 +472,4 @@ Firebug.console##timeEnd(Js.string "init"); Lwt.return () let _ = -Html.window##onload <- Html.handler (fun _ -> ignore (start ()); Js._false) +Html.window##.onload := Html.handler (fun _ -> ignore (start ()); Js._false) From e492cb882e461c97962f3a82f19d65848902e058 Mon Sep 17 00:00:00 2001 From: Stephane Glondu Date: Thu, 13 Aug 2020 15:28:41 +0200 Subject: [PATCH 3/3] Update britney data locations --- update_data.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/update_data.ml b/update_data.ml index c106e04..fb1a1e2 100644 --- a/update_data.ml +++ b/update_data.ml @@ -23,12 +23,12 @@ let src = ref "http://http.debian.net/debian/dists/" let hint_src = "https://release.debian.org/britney/hints/" -let britney_src = "https://release.debian.org/britney/data-b2/" +let britney_src = "https://release.debian.org/britney/state/" let britney_files = - [("Dates", `Testing, "Dates"); - ("Urgency", `Testing, "Urgency"); - ("testing_BugsV", `Testing, "BugsV"); - ("unstable_BugsV", `Unstable, "BugsV")] + [("age-policy-dates", `Testing, "Dates"); + ("age-policy-urgencies", `Testing, "Urgency"); + ("rc-bugs-testing", `Testing, "BugsV"); + ("rc-bugs-unstable", `Unstable, "BugsV")] let sects = ["main"; "contrib"; "non-free"]