Merge pull request #32 from talex5/save-image

Add export image to GTK menu

Author: talex5

README.md

@@ -126,6 +126,7 @@ Phases that usually involve sleeping are shown with a yellow background, but som
 
 ## Controls
 
+- Right click for a menu
 - F5 : reload the trace file
 - s : start-time (elapsed time at left edge of window since trace start)
 - d : duration (duration to show in the currently visible area of the window)

gtk/gtk_ui.ml

@@ -3,20 +3,24 @@ open Eio_trace
 let ( ==> ) signal callback =
   ignore (signal ~callback : GtkSignal.id)
 
+let (let*) = Result.bind
+
 let ui_xml = {|
 <ui>
   <popup name='PopupMenu'>
+    <menuitem action='export-image' />
     <menuitem action='viewport-set-start' />
     <menuitem action='viewport-set-duration' />
   </popup>
 </ui>
 |}
 
 let create ~title tracefile =
+  let last_export = ref None in
   let actions = GAction.action_group ~name:"main" () in
   let ui = GAction.ui_manager () in
   ui#insert_action_group actions 0;
-  let _id : GAction.ui_id = ui#add_ui_from_string ui_xml; in
+  let _id : GAction.ui_id = ui#add_ui_from_string ui_xml in
 
   let window = GWindow.window () in
   window#add_accel_group ui#get_accel_group;
@@ -112,6 +116,50 @@ let create ~title tracefile =
       )
   in
 
+  let alert message =
+    let dialog = GWindow.message_dialog ~title:"Error" ~buttons:GWindow.Buttons.ok ~message () in
+    dialog#show ();
+    match dialog#run () with
+    | `DELETE_EVENT | `OK -> dialog#destroy ()
+  in
+
+  let save_image () =
+    let dialog = GWindow.file_chooser_dialog ~title:"Export image" ~action:`SAVE ~parent:window () in
+    begin match !last_export with
+      | None ->
+        let dir = Filename.dirname tracefile in
+        ignore (dialog#set_current_folder dir : bool);
+        dialog#set_current_name ((Filename.basename tracefile |> Filename.remove_extension) ^ ".svg")
+      | Some path ->
+        ignore (dialog#set_filename path : bool)
+    end;
+    dialog#add_select_button_stock `SAVE `OK;
+    dialog#set_default_response `OK;
+    dialog#add_button_stock `CANCEL `CANCEL;
+    dialog#connect#response ==> (function
+        | `DELETE_EVENT | `CANCEL ->
+          dialog#destroy ()
+        | `OK ->
+          match
+            match dialog#get_filenames with
+            | [path] ->
+              let* fmt = Save.format_of_string (Filename.extension path) in
+              last_export := Some path;
+              Save.export_image v fmt path
+            | _ -> Error "Must select one path"
+          with
+          | Ok () -> dialog#destroy ()
+          | Error msg -> alert msg
+      );
+    dialog#show ();
+  in
+
+  GAction.add_action "export-image" actions
+    ~label:"Export image as..."
+    ~accel:"<control>e"
+    ~stock:`SAVE_AS
+    ~callback:(fun _a -> save_image ());
+
   GAction.add_action "viewport-set-start" actions
     ~label:"Set start time..."
     ~callback:(fun _a -> show_start ());
@@ -134,7 +182,8 @@ let create ~title tracefile =
           true
         ) else false
       ) else (
-        if keyval = GdkKeysyms._s then (
+        if GdkEvent.Key.state ev <> [] then false
+        else if keyval = GdkKeysyms._s then (
           show_start ();
           true
         ) else if keyval = GdkKeysyms._d then (

gtk/main.ml

@@ -2,10 +2,9 @@ open Eio_trace
 
 let (_ : string) = GMain.init ()
 
-let format_of_string = function
-  | ".svg" -> `Svg
-  | ".png" -> `Png
-  | x -> Fmt.failwith "Unknown format %S (should be .svg or .png)" x
+let or_die = function
+  | Ok x -> x
+  | Error msg -> failwith msg
 
 let show ?args tracefile =
   let title =
@@ -25,33 +24,15 @@ let render ?output ~start_time ?duration ~format tracefile =
     | Some x -> x
     | None -> Filename.remove_extension tracefile ^ format
   in
-  let format = format_of_string format in
+  let format = Save.format_of_string format |> or_die in
   let l = Layout.load (tracefile) in
   let v =
     View.of_layout l
       ~width:1280.
       ~height:((float l.height +. 0.5) *. View.pixels_per_row +. 2. *. View.v_margin)
   in
   View.zoom_to_fit v ~start_time ?duration;
-  let create =
-    match format with
-    | `Svg -> Cairo.SVG.create output
-    | `Png -> fun ~w ~h -> Cairo.Image.create RGB24 ~w:(int_of_float w) ~h:(int_of_float h)
-  in
-  let surface =
-    create
-    ~w:v.width
-    ~h:v.height
-  in
-  let cr = Cairo.create surface in
-  Cairo.rectangle cr 0.0 0.0 ~w:v.width ~h:v.height;
-  Cairo.clip cr;
-  Render_cairo.render v cr;
-  begin match format with
-    | `Svg -> ()
-    | `Png -> Cairo.PNG.write surface output
-  end;
-  Cairo.Surface.finish surface;
+  Save.export_image v format output |> or_die;
   Printf.printf "Wrote %S\n" output
 
 let () =

gtk/save.ml

@@ -0,0 +1,28 @@
+let format_of_string = function
+  | ".svg" -> Ok `Svg
+  | ".png" -> Ok `Png
+  | x -> Fmt.error "Unknown format %S (should be .svg or .png)" x
+
+let export_image (v : Eio_trace.View.t) fmt path =
+  try
+    let create =
+      match fmt with
+      | `Svg -> Cairo.SVG.create path
+      | `Png -> fun ~w ~h -> Cairo.Image.create RGB24 ~w:(int_of_float w) ~h:(int_of_float h)
+    in
+    let surface =
+      create
+        ~w:v.width
+        ~h:v.height
+    in
+    let cr = Cairo.create surface in
+    Cairo.rectangle cr 0.0 0.0 ~w:v.width ~h:v.height;
+    Cairo.clip cr;
+    Render_cairo.render v cr;
+    begin match fmt with
+      | `Svg -> ()
+      | `Png -> Cairo.PNG.write surface path
+    end;
+    Ok (Cairo.Surface.finish surface)
+  with ex ->
+    Error (Printexc.to_string ex)