ghc-vis 0.7.2.9 → 0.8
raw patch · 8 files changed
+467/−461 lines, 8 filesdep +gtk3dep −gtkdep ~xdot
Dependencies added: gtk3
Dependencies removed: gtk
Dependency ranges changed: xdot
Files
- data/main.ui +266/−260
- ghc-vis.cabal +4/−4
- nonghci-test.hs +1/−1
- src/GHC/Vis.hs +178/−169
- src/GHC/Vis/Internal.hs +0/−1
- src/GHC/Vis/Types.hs +3/−3
- src/GHC/Vis/View/Graph.hs +7/−11
- src/GHC/Vis/View/List.hs +8/−12
data/main.ui view
@@ -1,39 +1,7 @@ <?xml version="1.0" encoding="UTF-8"?>+<!-- Generated with glade 3.19.0 --> <interface>- <requires lib="gtk+" version="2.24"/>- <!-- interface-naming-policy project-wide -->- <object class="GtkAboutDialog" id="aboutdialog">- <property name="can_focus">False</property>- <property name="border_width">5</property>- <property name="type_hint">dialog</property>- <property name="program_name">ghc-vis</property>- <property name="website">http://felsin9.de/nnis/ghc-vis</property>- <property name="authors">Dennis Felsing-Joachim Breitner</property>- <child internal-child="vbox">- <object class="GtkVBox" id="dialog-vbox3">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="spacing">2</property>- <child internal-child="action_area">- <object class="GtkHButtonBox" id="dialog-action_area3">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="layout_style">end</property>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="pack_type">end</property>- <property name="position">0</property>- </packing>- </child>- <child>- <placeholder/>- </child>- </object>- </child>- </object>+ <requires lib="gtk+" version="3.0"/> <object class="GtkAdjustment" id="adjustment1"> <property name="lower">1</property> <property name="upper">100000</property>@@ -41,144 +9,20 @@ <property name="step_increment">1</property> <property name="page_increment">10</property> </object>- <object class="GtkDialog" id="depthdialog">- <property name="can_focus">False</property>- <property name="border_width">5</property>- <property name="resizable">False</property>- <property name="destroy_with_parent">True</property>- <property name="type_hint">dialog</property>- <child internal-child="vbox">- <object class="GtkVBox" id="dialog-vbox5">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="spacing">2</property>- <child internal-child="action_area">- <object class="GtkHButtonBox" id="dialog-action_area5">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="layout_style">end</property>- <child>- <object class="GtkButton" id="depthcancel">- <property name="label">gtk-cancel</property>- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="receives_default">True</property>- <property name="use_stock">True</property>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">False</property>- <property name="position">0</property>- </packing>- </child>- <child>- <object class="GtkButton" id="depthok">- <property name="label">gtk-ok</property>- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="receives_default">True</property>- <property name="use_stock">True</property>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">False</property>- <property name="position">1</property>- </packing>- </child>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="pack_type">end</property>- <property name="position">0</property>- </packing>- </child>- <child>- <object class="GtkHBox" id="hbox1">- <property name="visible">True</property>- <property name="can_focus">False</property>- <child>- <object class="GtkLabel" id="depthlabel">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="xalign">1</property>- <property name="label" translatable="yes">Depth: </property>- <property name="justify">right</property>- </object>- <packing>- <property name="expand">True</property>- <property name="fill">True</property>- <property name="position">0</property>- </packing>- </child>- <child>- <object class="GtkSpinButton" id="depthspin">- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="invisible_char">●</property>- <property name="activates_default">True</property>- <property name="width_chars">4</property>- <property name="shadow_type">none</property>- <property name="primary_icon_activatable">False</property>- <property name="secondary_icon_activatable">False</property>- <property name="primary_icon_sensitive">True</property>- <property name="secondary_icon_sensitive">True</property>- <property name="adjustment">adjustment1</property>- <property name="climb_rate">1</property>- <property name="numeric">True</property>- </object>- <packing>- <property name="expand">True</property>- <property name="fill">True</property>- <property name="position">1</property>- </packing>- </child>- </object>- <packing>- <property name="expand">True</property>- <property name="fill">True</property>- <property name="position">1</property>- </packing>- </child>- <child>- <placeholder/>- </child>- </object>- </child>- <action-widgets>- <action-widget response="-6">depthcancel</action-widget>- <action-widget response="-5">depthok</action-widget>- </action-widgets>- </object> <object class="GtkImage" id="image1"> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="stock">gtk-save</property>+ <property name="stock">gtk-new</property> </object> <object class="GtkImage" id="image10"> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="stock">gtk-undo</property>+ <property name="stock">gtk-media-forward</property> </object> <object class="GtkImage" id="image11"> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="stock">gtk-properties</property>- </object>- <object class="GtkImage" id="image12">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="stock">gtk-zoom-in</property>- </object>- <object class="GtkImage" id="image13">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="stock">gtk-zoom-out</property>- </object>- <object class="GtkImage" id="image14">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="stock">gtk-missing-image</property>+ <property name="stock">gtk-justify-left</property> </object> <object class="GtkImage" id="image2"> <property name="visible">True</property>@@ -188,118 +32,37 @@ <object class="GtkImage" id="image3"> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="stock">gtk-new</property>+ <property name="stock">gtk-zoom-in</property> </object> <object class="GtkImage" id="image4"> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="stock">gtk-jump-to</property>+ <property name="stock">gtk-zoom-out</property> </object> <object class="GtkImage" id="image5"> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="stock">gtk-refresh</property>+ <property name="stock">gtk-undo</property> </object> <object class="GtkImage" id="image6"> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="stock">gtk-missing-image</property>+ <property name="stock">gtk-jump-to</property> </object> <object class="GtkImage" id="image7"> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="stock">gtk-justify-left</property>+ <property name="stock">gtk-refresh</property> </object> <object class="GtkImage" id="image8"> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="stock">gtk-media-rewind</property>+ <property name="stock">gtk-properties</property> </object> <object class="GtkImage" id="image9"> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="stock">gtk-media-forward</property>- </object>- <object class="GtkWindow" id="legenddialog">- <property name="can_focus">False</property>- <property name="title" translatable="yes">ghc-vis Legend</property>- <property name="default_width">440</property>- <property name="default_height">250</property>- <property name="destroy_with_parent">True</property>- <property name="type_hint">dialog</property>- <child>- <object class="GtkDrawingArea" id="legenddrawingarea">- <property name="visible">True</property>- <property name="can_focus">False</property>- </object>- </child>- </object>- <object class="GtkFileChooserDialog" id="savedialog">- <property name="can_focus">False</property>- <property name="border_width">5</property>- <property name="title" translatable="yes">ghc-vis Save</property>- <property name="role">GtkFileChooserDialog</property>- <property name="type_hint">dialog</property>- <property name="action">save</property>- <child internal-child="vbox">- <object class="GtkVBox" id="dialog-vbox1">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="spacing">2</property>- <child internal-child="action_area">- <object class="GtkHButtonBox" id="dialog-action_area1">- <property name="visible">True</property>- <property name="can_focus">False</property>- <property name="layout_style">end</property>- <child>- <object class="GtkButton" id="cancelbutton">- <property name="label">gtk-cancel</property>- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="receives_default">True</property>- <property name="use_stock">True</property>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">False</property>- <property name="position">0</property>- </packing>- </child>- <child>- <object class="GtkButton" id="savebutton">- <property name="label">gtk-save</property>- <property name="visible">True</property>- <property name="can_focus">True</property>- <property name="has_focus">True</property>- <property name="is_focus">True</property>- <property name="can_default">True</property>- <property name="has_default">True</property>- <property name="receives_default">True</property>- <property name="use_stock">True</property>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">False</property>- <property name="position">1</property>- </packing>- </child>- </object>- <packing>- <property name="expand">False</property>- <property name="fill">True</property>- <property name="pack_type">end</property>- <property name="position">0</property>- </packing>- </child>- <child>- <placeholder/>- </child>- </object>- </child>- <action-widgets>- <action-widget response="-6">cancelbutton</action-widget>- <action-widget response="-5">savebutton</action-widget>- </action-widgets>+ <property name="stock">gtk-media-rewind</property> </object> <object class="GtkWindow" id="window"> <property name="can_focus">False</property>@@ -307,9 +70,10 @@ <property name="default_width">640</property> <property name="default_height">480</property> <child>- <object class="GtkVBox" id="vbox1">+ <object class="GtkBox" id="vbox1"> <property name="visible">True</property> <property name="can_focus">False</property>+ <property name="orientation">vertical</property> <child> <object class="GtkMenuBar" id="menubar1"> <property name="visible">True</property>@@ -329,8 +93,9 @@ <property name="label" translatable="yes">Clear (:clear, c)</property> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="image">image3</property>+ <property name="image">image1</property> <property name="use_stock">False</property>+ <property name="always_show_image">True</property> </object> </child> <child>@@ -340,6 +105,7 @@ <property name="can_focus">False</property> <property name="image">image2</property> <property name="use_stock">False</property>+ <property name="always_show_image">True</property> </object> </child> <child>@@ -355,6 +121,7 @@ <property name="can_focus">False</property> <property name="use_underline">True</property> <property name="use_stock">True</property>+ <property name="always_show_image">True</property> </object> </child> </object>@@ -408,8 +175,9 @@ <property name="label" translatable="yes">Zoom in (+)</property> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="image">image12</property>+ <property name="image">image3</property> <property name="use_stock">False</property>+ <property name="always_show_image">True</property> </object> </child> <child>@@ -417,8 +185,9 @@ <property name="label" translatable="yes">Zoom out (-)</property> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="image">image13</property>+ <property name="image">image4</property> <property name="use_stock">False</property>+ <property name="always_show_image">True</property> </object> </child> <child>@@ -426,8 +195,9 @@ <property name="label" translatable="yes">Restore collapsed nodes (:restore, C)</property> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="image">image10</property>+ <property name="image">image5</property> <property name="use_stock">False</property>+ <property name="always_show_image">True</property> </object> </child> <child>@@ -435,8 +205,9 @@ <property name="label" translatable="yes">Switch (:switch, v)</property> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="image">image4</property>+ <property name="image">image6</property> <property name="use_stock">False</property>+ <property name="always_show_image">True</property> </object> </child> <child>@@ -444,8 +215,9 @@ <property name="label" translatable="yes">Update (:update, u)</property> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="image">image5</property>+ <property name="image">image7</property> <property name="use_stock">False</property>+ <property name="always_show_image">True</property> </object> </child> <child>@@ -453,8 +225,9 @@ <property name="label" translatable="yes">Set depth (:setDepth)</property> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="image">image11</property>+ <property name="image">image8</property> <property name="use_stock">False</property>+ <property name="always_show_image">True</property> </object> </child> </object>@@ -476,8 +249,9 @@ <property name="label" translatable="yes">Back (:timeback, ,)</property> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="image">image8</property>+ <property name="image">image9</property> <property name="use_stock">False</property>+ <property name="always_show_image">True</property> </object> </child> <child>@@ -485,8 +259,9 @@ <property name="label" translatable="yes">Forward (:timeforward, .)</property> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="image">image9</property>+ <property name="image">image10</property> <property name="use_stock">False</property>+ <property name="always_show_image">True</property> </object> </child> </object>@@ -508,8 +283,9 @@ <property name="label" translatable="yes">Legend</property> <property name="visible">True</property> <property name="can_focus">False</property>- <property name="image">image7</property>+ <property name="image">image11</property> <property name="use_stock">False</property>+ <property name="always_show_image">True</property> </object> </child> <child>@@ -519,6 +295,7 @@ <property name="can_focus">False</property> <property name="use_underline">True</property> <property name="use_stock">True</property>+ <property name="always_show_image">True</property> </object> </child> </object>@@ -543,6 +320,235 @@ <property name="position">1</property> </packing> </child>+ </object>+ </child>+ </object>+ <object class="GtkAboutDialog" id="aboutdialog">+ <property name="can_focus">False</property>+ <property name="border_width">5</property>+ <property name="window_position">center-on-parent</property>+ <property name="type_hint">utility</property>+ <property name="transient_for">window</property>+ <property name="program_name">ghc-vis</property>+ <property name="website">http://felsin9.de/nnis/ghc-vis</property>+ <property name="authors">Dennis Felsing+Joachim Breitner</property>+ <property name="logo_icon_name">image-missing</property>+ <child internal-child="vbox">+ <object class="GtkBox" id="dialog-vbox3">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="orientation">vertical</property>+ <property name="spacing">2</property>+ <child internal-child="action_area">+ <object class="GtkButtonBox" id="dialog-action_area3">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="layout_style">end</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="pack_type">end</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <placeholder/>+ </child>+ </object>+ </child>+ </object>+ <object class="GtkDialog" id="depthdialog">+ <property name="can_focus">False</property>+ <property name="border_width">5</property>+ <property name="resizable">False</property>+ <property name="destroy_with_parent">True</property>+ <property name="type_hint">dialog</property>+ <property name="transient_for">window</property>+ <child internal-child="vbox">+ <object class="GtkBox" id="dialog-vbox5">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="orientation">vertical</property>+ <property name="spacing">2</property>+ <child internal-child="action_area">+ <object class="GtkButtonBox" id="dialog-action_area5">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="layout_style">end</property>+ <child>+ <object class="GtkButton" id="depthcancel">+ <property name="label">gtk-cancel</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ <property name="use_stock">True</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkButton" id="depthok">+ <property name="label">gtk-ok</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ <property name="use_stock">True</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">1</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="pack_type">end</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkBox" id="hbox1">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <child>+ <object class="GtkLabel" id="depthlabel">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="label" translatable="yes">Depth: </property>+ <property name="justify">right</property>+ <property name="xalign">1</property>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkSpinButton" id="depthspin">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="invisible_char">●</property>+ <property name="activates_default">True</property>+ <property name="width_chars">4</property>+ <property name="shadow_type">none</property>+ <property name="primary_icon_activatable">False</property>+ <property name="secondary_icon_activatable">False</property>+ <property name="adjustment">adjustment1</property>+ <property name="climb_rate">1</property>+ <property name="numeric">True</property>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">1</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">1</property>+ </packing>+ </child>+ <child>+ <placeholder/>+ </child>+ </object>+ </child>+ <action-widgets>+ <action-widget response="-6">depthcancel</action-widget>+ <action-widget response="-5">depthok</action-widget>+ </action-widgets>+ </object>+ <object class="GtkFileChooserDialog" id="savedialog">+ <property name="can_focus">False</property>+ <property name="border_width">5</property>+ <property name="title" translatable="yes">ghc-vis Save</property>+ <property name="role">GtkFileChooserDialog</property>+ <property name="type_hint">dialog</property>+ <property name="gravity">west</property>+ <property name="transient_for">window</property>+ <property name="action">save</property>+ <child internal-child="vbox">+ <object class="GtkBox" id="dialog-vbox1">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="orientation">vertical</property>+ <property name="spacing">2</property>+ <child internal-child="action_area">+ <object class="GtkButtonBox" id="dialog-action_area1">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="layout_style">end</property>+ <child>+ <object class="GtkButton" id="cancelbutton">+ <property name="label">gtk-cancel</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ <property name="use_stock">True</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkButton" id="savebutton">+ <property name="label">gtk-save</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="has_focus">True</property>+ <property name="is_focus">True</property>+ <property name="can_default">True</property>+ <property name="has_default">True</property>+ <property name="receives_default">True</property>+ <property name="use_stock">True</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">1</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="pack_type">end</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <placeholder/>+ </child>+ </object>+ </child>+ <action-widgets>+ <action-widget response="-6">cancelbutton</action-widget>+ <action-widget response="-5">savebutton</action-widget>+ </action-widgets>+ </object>+ <object class="GtkWindow" id="legenddialog">+ <property name="can_focus">False</property>+ <property name="title" translatable="yes">ghc-vis Legend</property>+ <property name="default_width">440</property>+ <property name="default_height">250</property>+ <property name="destroy_with_parent">True</property>+ <property name="type_hint">dialog</property>+ <child>+ <object class="GtkDrawingArea" id="legenddrawingarea">+ <property name="visible">True</property>+ <property name="can_focus">False</property> </object> </child> </object>
ghc-vis.cabal view
@@ -1,5 +1,5 @@ name: ghc-vis-version: 0.7.2.9+version: 0.8 license: BSD3 license-file: LICENSE category: GHC, Debug, Development@@ -8,7 +8,7 @@ author: Dennis Felsing, Joachim Breitner maintainer: Dennis Felsing <dennis@felsin9.de> homepage: http://felsin9.de/nnis/ghc-vis-copyright: Dennis Felsing 2012-2013+copyright: Dennis Felsing 2012-2016 synopsis: Live visualization of data structures in GHCi description: Visualize live data structures in GHCi. Evaluation is not forced and you can interact with the visualized data@@ -47,7 +47,7 @@ text >= 0.11 && < 1.3, transformers >= 0.3 && < 0.5, containers >= 0.4 && < 0.6,- gtk >= 0.12 && < 0.15,+ gtk3 >= 0.12 && < 0.15, svgcairo >= 0.12 && < 0.14, cairo >= 0.12 && < 0.14, ghc-heap-view >= 0.5@@ -57,7 +57,7 @@ if flag(graph) Other-modules: GHC.Vis.View.Graph.Parser GHC.Vis.View.Graph Build-depends: graphviz >= 2999.17,- xdot >= 0.2.4+ xdot >= 0.3 Cpp-options: -DGRAPH_VIEW if flag(full)
nonghci-test.hs view
@@ -8,7 +8,7 @@ let d = [1..] putStrLn $ show $ d !! 1 - visualization+ vis view a "a" view b "b" view c "c"
src/GHC/Vis.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, RankNTypes, ImpredicativeTypes #-}+{-# LANGUAGE CPP, RankNTypes, ImpredicativeTypes, OverloadedStrings #-} {- | Module : GHC.Vis Copyright : (c) Dennis Felsing@@ -57,12 +57,13 @@ import Prelude #endif -import Graphics.UI.Gtk hiding (Box, Signal, response)-import qualified Graphics.UI.Gtk.Gdk.Events as E+import Graphics.UI.Gtk hiding (Box, Signal) import System.IO import Control.Concurrent import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class import Control.Exception hiding (evaluate) @@ -70,7 +71,7 @@ import Data.IORef import Data.Version -import qualified Data.Text as Text+import Data.Text () import qualified Data.IntMap as M import System.Timeout@@ -257,10 +258,9 @@ ] (uncurry $ windowSetDefaultSize window) defaultSize - onExpose canvas $ const $ do+ on canvas draw $ do runCorrect redraw >>= \f -> f canvas- runCorrect move >>= \f -> f canvas- return True+ runCorrect move >>= \f -> liftIO $ f canvas dummy <- windowNew @@ -306,158 +306,166 @@ setupGUI :: (WidgetClass w1, WidgetClass w2, WidgetClass w3) => w1 -> w2 -> w3 -> IO () setupGUI window canvas legendCanvas = do- onMotionNotify canvas False $ \e -> do- state <- readIORef visState- modifyIORef visState (\s -> s {mousePos = (E.eventX e, E.eventY e)})+ widgetAddEvents canvas [PointerMotionMask]+ on canvas motionNotifyEvent $ do+ (x,y) <- eventCoordinates+ lift $ do+ state <- readIORef visState+ modifyIORef visState (\s -> s {mousePos = (x,y)}) - if dragging state- then do- let (oldX, oldY) = mousePos state- (deltaX, deltaY) = (E.eventX e - oldX, E.eventY e - oldY)- (oldPosX, oldPosY) = position state- modifyIORef visState (\s -> s {position = (oldPosX + deltaX, oldPosY + deltaY)})- widgetQueueDraw canvas- else- runCorrect move >>= \f -> f canvas+ if dragging state+ then do+ let (oldX, oldY) = mousePos state+ (deltaX, deltaY) = (x - oldX, y - oldY)+ (oldPosX, oldPosY) = position state+ modifyIORef visState (\s -> s {position = (oldPosX + deltaX, oldPosY + deltaY)})+ widgetQueueDraw canvas+ else+ runCorrect move >>= \f -> f canvas - return True+ return True - onButtonPress canvas $ \e -> do- when (E.eventButton e == LeftButton && E.eventClick e == SingleClick) $- join $ runCorrect click+ on canvas buttonPressEvent $ do+ button <- eventButton+ eClick <- eventClick+ lift $ do+ when (button == LeftButton && eClick == SingleClick) $+ join $ runCorrect click - when (E.eventButton e == RightButton && E.eventClick e == SingleClick) $- modifyIORef visState (\s -> s {dragging = True})+ when (button == RightButton && eClick == SingleClick) $+ modifyIORef visState (\s -> s {dragging = True}) - when (E.eventButton e == MiddleButton && E.eventClick e == SingleClick) $ do- modifyIORef visState (\s -> s {zoomRatio = 1, position = (0, 0)})- widgetQueueDraw canvas+ when (button == MiddleButton && eClick == SingleClick) $ do+ modifyIORef visState (\s -> s {zoomRatio = 1, position = (0, 0)})+ widgetQueueDraw canvas return True - onButtonRelease canvas $ \e -> do- when (E.eventButton e == RightButton) $- modifyIORef visState (\s -> s {dragging = False})+ on canvas buttonReleaseEvent $ do+ button <- eventButton+ lift $ do+ when (button == RightButton) $+ modifyIORef visState (\s -> s {dragging = False}) - return True+ return True - onScroll canvas $ \e -> do- state <- readIORef visState+ on canvas scrollEvent $ do+ direction <- eventScrollDirection+ lift $ do+ state <- readIORef visState - when (E.eventDirection e == ScrollUp) $ do- let newZoomRatio = zoomRatio state * zoomIncrement- newPos <- zoomImage canvas state newZoomRatio (mousePos state)- modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos}) - when (E.eventDirection e == ScrollDown) $ do- let newZoomRatio = zoomRatio state / zoomIncrement- newPos <- zoomImage canvas state newZoomRatio (mousePos state)- modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos})+ when (direction == ScrollUp) $ do+ let newZoomRatio = zoomRatio state * zoomIncrement+ newPos <- zoomImage canvas state newZoomRatio (mousePos state)+ modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos}) - widgetQueueDraw canvas- return True+ when (direction == ScrollDown) $ do+ let newZoomRatio = zoomRatio state / zoomIncrement+ newPos <- zoomImage canvas state newZoomRatio (mousePos state)+ modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos}) - onKeyPress window $ \e -> do- state <- readIORef visState+ widgetQueueDraw canvas+ return True -#if MIN_VERSION_gtk(0,13,0)- let eventKeyName = Text.unpack . E.eventKeyName-#else- let eventKeyName = E.eventKeyName-#endif+ on window keyPressEvent $ do+ eKeyName <- eventKeyName+ lift $ do+ state <- readIORef visState - when (eventKeyName e `elem` ["plus", "Page_Up", "KP_Add"]) $ do- let newZoomRatio = zoomRatio state * zoomIncrement- (oldX, oldY) = position state- newPos = (oldX*zoomIncrement, oldY*zoomIncrement)- modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos}) - when (eventKeyName e `elem` ["minus", "Page_Down", "KP_Subtract"]) $ do- let newZoomRatio = zoomRatio state / zoomIncrement- (oldX, oldY) = position state- newPos = (oldX/zoomIncrement, oldY/zoomIncrement)- modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos})+ when (eKeyName `elem` ["plus", "Page_Up", "KP_Add"]) $ do+ let newZoomRatio = zoomRatio state * zoomIncrement+ (oldX, oldY) = position state+ newPos = (oldX*zoomIncrement, oldY*zoomIncrement)+ modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos}) - when (eventKeyName e `elem` ["0", "equal"]) $- modifyIORef visState (\s -> s {zoomRatio = 1, position = (0, 0)})+ when (eKeyName `elem` ["minus", "Page_Down", "KP_Subtract"]) $ do+ let newZoomRatio = zoomRatio state / zoomIncrement+ (oldX, oldY) = position state+ newPos = (oldX/zoomIncrement, oldY/zoomIncrement)+ modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos}) - when (eventKeyName e `elem` ["Left", "h", "a"]) $- modifyIORef visState (\s ->- let (x,y) = position s- newX = x + positionIncrement- in s {position = (newX, y)})+ when (eKeyName `elem` ["0", "equal"]) $+ modifyIORef visState (\s -> s {zoomRatio = 1, position = (0, 0)}) - when (eventKeyName e `elem` ["Right", "l", "d"]) $- modifyIORef visState (\s ->- let (x,y) = position s- newX = x - positionIncrement- in s {position = (newX, y)})+ when (eKeyName `elem` ["Left", "h", "a"]) $+ modifyIORef visState (\s ->+ let (x,y) = position s+ newX = x + positionIncrement+ in s {position = (newX, y)}) - when (eventKeyName e `elem` ["Up", "k", "w"]) $- modifyIORef visState (\s ->- let (x,y) = position s- newY = y + positionIncrement- in s {position = (x, newY)})+ when (eKeyName `elem` ["Right", "l", "d"]) $+ modifyIORef visState (\s ->+ let (x,y) = position s+ newX = x - positionIncrement+ in s {position = (newX, y)}) - when (eventKeyName e `elem` ["Down", "j", "s"]) $- modifyIORef visState (\s ->- let (x,y) = position s- newY = y - positionIncrement- in s {position = (x, newY)})+ when (eKeyName `elem` ["Up", "k", "w"]) $+ modifyIORef visState (\s ->+ let (x,y) = position s+ newY = y + positionIncrement+ in s {position = (x, newY)}) - when (eventKeyName e `elem` ["H", "A"]) $- modifyIORef visState (\s ->- let (x,y) = position s- newX = x + bigPositionIncrement- in s {position = (newX, y)})+ when (eKeyName `elem` ["Down", "j", "s"]) $+ modifyIORef visState (\s ->+ let (x,y) = position s+ newY = y - positionIncrement+ in s {position = (x, newY)}) - when (eventKeyName e `elem` ["L", "D"]) $- modifyIORef visState (\s ->- let (x,y) = position s- newX = x - bigPositionIncrement- in s {position = (newX, y)})+ when (eKeyName `elem` ["H", "A"]) $+ modifyIORef visState (\s ->+ let (x,y) = position s+ newX = x + bigPositionIncrement+ in s {position = (newX, y)}) - when (eventKeyName e `elem` ["K", "W"]) $- modifyIORef visState (\s ->- let (x,y) = position s- newY = y + bigPositionIncrement- in s {position = (x, newY)})+ when (eKeyName `elem` ["L", "D"]) $+ modifyIORef visState (\s ->+ let (x,y) = position s+ newX = x - bigPositionIncrement+ in s {position = (newX, y)}) - when (eventKeyName e `elem` ["J", "S"]) $- modifyIORef visState (\s ->- let (x,y) = position s- newY = y - bigPositionIncrement- in s {position = (x, newY)})+ when (eKeyName `elem` ["K", "W"]) $+ modifyIORef visState (\s ->+ let (x,y) = position s+ newY = y + bigPositionIncrement+ in s {position = (x, newY)}) - when (eventKeyName e `elem` ["space", "Return", "KP_Enter"]) $- join $ runCorrect click+ when (eKeyName `elem` ["J", "S"]) $+ modifyIORef visState (\s ->+ let (x,y) = position s+ newY = y - bigPositionIncrement+ in s {position = (x, newY)}) - when (eventKeyName e `elem` ["v"]) $- put SwitchSignal+ when (eKeyName `elem` ["space", "Return", "KP_Enter"]) $+ join $ runCorrect click - when (eventKeyName e `elem` ["c"]) $- put ClearSignal+ when (eKeyName `elem` ["v"]) $+ put SwitchSignal - when (eventKeyName e `elem` ["C"]) $- put RestoreSignal+ when (eKeyName `elem` ["c"]) $+ put ClearSignal - when (eventKeyName e `elem` ["u"]) $- put UpdateSignal+ when (eKeyName `elem` ["C"]) $+ put RestoreSignal - when (eventKeyName e `elem` ["comma", "bracketleft"]) $- put $ HistorySignal (+1)+ when (eKeyName `elem` ["u"]) $+ put UpdateSignal - when (eventKeyName e `elem` ["period", "bracketright"]) $- put $ HistorySignal (\x -> x - 1)+ when (eKeyName `elem` ["comma", "bracketleft"]) $+ put $ HistorySignal (+1) - widgetQueueDraw canvas- return True+ when (eKeyName `elem` ["period", "bracketright"]) $+ put $ HistorySignal (\x -> x - 1) + widgetQueueDraw canvas+ return True+ widgetShowAll window reactThread <- forkIO $ react canvas legendCanvas --onDestroy window mainQuit -- Causes :r problems with multiple windows- onDestroy window (quit reactThread)+ on window destroyEvent $ lift $ quit reactThread >> return True mainGUI return ()@@ -597,9 +605,9 @@ where doSwitch = putStrLn "Cannot switch view: Graph view disabled at build" #endif -runCorrect :: (View -> f) -> IO f+runCorrect :: MonadIO m => (View -> f) -> m f runCorrect f = do- s <- readIORef visState+ s <- liftIO $ readIORef visState return $ f $ views !! fromEnum (T.view s) zoomImage :: WidgetClass w1 => w1 -> State -> Double -> T.Point -> IO T.Point@@ -643,36 +651,37 @@ set aboutDialog [aboutDialogVersion := showVersion My.version] - onResponse saveDialog $ fileSave saveDialog- onResponse depthDialog $ setDepthDialog depthDialog depthSpin- onResponse aboutDialog $ const $ widgetHide aboutDialog+ on saveDialog response $ fileSave saveDialog+ on depthDialog response $ setDepthDialog depthDialog depthSpin+ on aboutDialog response $ const $ widgetHide aboutDialog - onDelete saveDialog $ const $ widgetHide saveDialog >> return True- onDelete aboutDialog $ const $ widgetHide aboutDialog >> return True- onDelete legendDialog $ const $ widgetHide legendDialog >> return True+ on saveDialog deleteEvent $ lift $ widgetHide saveDialog >> return True+ on aboutDialog deleteEvent $ lift $ widgetHide aboutDialog >> return True+ on legendDialog deleteEvent $ lift $ widgetHide legendDialog >> return True let setDepthSpin = do s <- readIORef visState spinButtonSetValue depthSpin $ fromIntegral $ heapDepth s - getO castToMenuItem "clear" >>= \item -> onActivateLeaf item clear- getO castToMenuItem "switch" >>= \item -> onActivateLeaf item switch- getO castToMenuItem "restore" >>= \item -> onActivateLeaf item restore- getO castToMenuItem "update" >>= \item -> onActivateLeaf item update- getO castToMenuItem "setdepth" >>= \item -> onActivateLeaf item $ setDepthSpin >> widgetShow depthDialog- getO castToMenuItem "export" >>= \item -> onActivateLeaf item $ widgetShow saveDialog- getO castToMenuItem "quit" >>= \item -> onActivateLeaf item $ widgetDestroy window- getO castToMenuItem "about" >>= \item -> onActivateLeaf item $ widgetShow aboutDialog- getO castToMenuItem "legend" >>= \item -> onActivateLeaf item $ widgetShow legendDialog- getO castToMenuItem "timeback" >>= \item -> onActivateLeaf item $ history (+1)- getO castToMenuItem "timeforward" >>= \item -> onActivateLeaf item $ history (\x -> x - 1)- getO castToMenuItem "zoomin" >>= \item -> onActivateLeaf item $ zoom canvas (*1.25)- getO castToMenuItem "zoomout" >>= \item -> onActivateLeaf item $ zoom canvas (/1.25)- getO castToMenuItem "left" >>= \item -> onActivateLeaf item $ movePos canvas (\(x,y) -> (x + positionIncrement, y))- getO castToMenuItem "right" >>= \item -> onActivateLeaf item $ movePos canvas (\(x,y) -> (x - positionIncrement, y))- getO castToMenuItem "up" >>= \item -> onActivateLeaf item $ movePos canvas (\(x,y) -> (x, y + positionIncrement))- getO castToMenuItem "down" >>= \item -> onActivateLeaf item $ movePos canvas (\(x,y) -> (x, y - positionIncrement)) + getO castToMenuItem "clear" >>= \item -> on item menuItemActivated clear+ getO castToMenuItem "switch" >>= \item -> on item menuItemActivated switch+ getO castToMenuItem "restore" >>= \item -> on item menuItemActivated restore+ getO castToMenuItem "update" >>= \item -> on item menuItemActivated update+ getO castToMenuItem "setdepth" >>= \item -> on item menuItemActivated $ setDepthSpin >> widgetShow depthDialog+ getO castToMenuItem "export" >>= \item -> on item menuItemActivated $ widgetShow saveDialog+ getO castToMenuItem "quit" >>= \item -> on item menuItemActivated $ widgetDestroy window+ getO castToMenuItem "about" >>= \item -> on item menuItemActivated $ widgetShow aboutDialog+ getO castToMenuItem "legend" >>= \item -> on item menuItemActivated $ widgetShow legendDialog+ getO castToMenuItem "timeback" >>= \item -> on item menuItemActivated $ history (+1)+ getO castToMenuItem "timeforward" >>= \item -> on item menuItemActivated $ history (\x -> x - 1)+ getO castToMenuItem "zoomin" >>= \item -> on item menuItemActivated $ zoom canvas (*1.25)+ getO castToMenuItem "zoomout" >>= \item -> on item menuItemActivated $ zoom canvas (/1.25)+ getO castToMenuItem "left" >>= \item -> on item menuItemActivated $ movePos canvas (\(x,y) -> (x + positionIncrement, y))+ getO castToMenuItem "right" >>= \item -> on item menuItemActivated $ movePos canvas (\(x,y) -> (x - positionIncrement, y))+ getO castToMenuItem "up" >>= \item -> on item menuItemActivated $ movePos canvas (\(x,y) -> (x, y + positionIncrement))+ getO castToMenuItem "down" >>= \item -> on item menuItemActivated $ movePos canvas (\(x,y) -> (x, y - positionIncrement))+ widgetModifyBg canvas StateNormal backgroundColor widgetModifyBg legendCanvas StateNormal backgroundColor @@ -681,18 +690,18 @@ legendListSVG <- My.getDataFileName "data/legend_list.svg" >>= svgNewFromFile legendGraphSVG <- My.getDataFileName "data/legend_graph.svg" >>= svgNewFromFile - onExpose canvas $ const $ do- boxes <- readMVar visBoxes+ on canvas draw $ do+ boxes <- liftIO $ readMVar visBoxes if null boxes then renderSVGScaled canvas welcomeSVG else do runCorrect redraw >>= \f -> f canvas- runCorrect move >>= \f -> f canvas- return True+ runCorrect move >>= \f -> liftIO $ f canvas+ return () - onExpose legendCanvas $ const $ do- state <- readIORef visState+ on legendCanvas draw $ do+ state <- liftIO $ readIORef visState renderSVGScaled legendCanvas $ case T.view state of ListView -> legendListSVG GraphView -> legendGraphSVG@@ -700,8 +709,8 @@ setupGUI window canvas legendCanvas fileSave :: FileChooserDialog -> ResponseId -> IO ()-fileSave fcdialog response = do- case response of+fileSave fcdialog responseId = do+ case responseId of ResponseOk -> do Just filename <- fileChooserGetFilename fcdialog mbError <- export' filename case mbError of@@ -709,14 +718,14 @@ Just errorMsg -> do errorDialog <- messageDialogNew Nothing [] MessageError ButtonsOk errorMsg widgetShow errorDialog- onResponse errorDialog $ const $ widgetHide errorDialog+ on errorDialog response $ const $ widgetHide errorDialog return () _ -> return () widgetHide fcdialog setDepthDialog :: Dialog -> SpinButton -> ResponseId -> IO ()-setDepthDialog depthDialog depthSpin response = do- case response of+setDepthDialog depthDialog depthSpin responseId = do+ case responseId of ResponseOk -> do depth <- spinButtonGetValue depthSpin setDepth $ round depth _ -> return ()@@ -729,23 +738,23 @@ fileFilterSetName filt $ name ++ " (" ++ filterString ++ ")" fileChooserAddFilter dialog filt -renderSVGScaled :: (WidgetClass w) => w -> SVG -> IO Bool+renderSVGScaled :: (WidgetClass w) => w -> SVG -> Render () renderSVGScaled canvas svg = do- E.Rectangle _ _ rw2 rh2 <- widgetGetAllocation canvas- win <- widgetGetDrawWindow canvas- renderWithDrawable win $ do- let (cx2, cy2) = svgGetSize svg+ rw2 <- liftIO $ widgetGetAllocatedWidth canvas+ rh2 <- liftIO $ widgetGetAllocatedHeight canvas+ let (cx2, cy2) = svgGetSize svg - (rw,rh) = (fromIntegral rw2, fromIntegral rh2)- (cx,cy) = (fromIntegral cx2, fromIntegral cy2)+ (rw,rh) = (fromIntegral rw2, fromIntegral rh2)+ (cx,cy) = (fromIntegral cx2, fromIntegral cy2) - -- Proportional scaling- (sx,sy) = (min (rw/cx) (rh/cy), sx)- (ox,oy) = (rw/2 - sx*cx/2, rh/2 - sy*cy/2)+ -- Proportional scaling+ (sx,sy) = (min (rw/cx) (rh/cy), sx)+ (ox,oy) = (rw/2 - sx*cx/2, rh/2 - sy*cy/2) - translate ox oy- scale sx sy- svgRender svg+ translate ox oy+ scale sx sy+ svgRender svg+ return () #endif -- Zoom into mouse, but only working from (0,0)
src/GHC/Vis/Internal.hs view
@@ -24,7 +24,6 @@ import Control.Monad import Control.Monad.State hiding (State, fix) -import Data.Word import Data.Char import Data.List hiding (insert) import qualified Data.IntMap as M
src/GHC/Vis/Types.hs view
@@ -26,7 +26,7 @@ import qualified Control.Monad.State as MS import Graphics.UI.Gtk hiding (Box, Signal, Point)-import Graphics.Rendering.Cairo+import Graphics.Rendering.Cairo hiding (x) -- | A simple Point type Point = (Double, Double)@@ -46,9 +46,9 @@ -- | All functions a view has to provide data View = View- { redraw :: WidgetClass w => w -> IO ()+ { redraw :: forall w. WidgetClass w => w -> Render () , click :: IO ()- , move :: WidgetClass w => w -> IO ()+ , move :: forall w. WidgetClass w => w -> IO () , updateObjects :: [NamedBox] -> IO () , exportView :: DrawFunction -> String -> IO () }
src/GHC/Vis/View/Graph.hs view
@@ -19,7 +19,7 @@ import Prelude hiding (catch) #endif -import Graphics.UI.Gtk hiding (Box, Signal, Rectangle, Object)+import Graphics.UI.Gtk hiding (Box, Signal, Rectangle, draw) import qualified Graphics.UI.Gtk as Gtk import Graphics.Rendering.Cairo hiding (x, y) @@ -80,14 +80,15 @@ -- | Draw visualization to screen, called on every update or when it's -- requested from outside the program.-redraw :: WidgetClass w => w -> IO ()+redraw :: WidgetClass w => w -> Render () redraw canvas = do- s <- readIORef state- Gtk.Rectangle _ _ rw2 rh2 <- widgetGetAllocation canvas+ s <- liftIO $ readIORef state+ rw2 <- liftIO $ Gtk.widgetGetAllocatedWidth canvas+ rh2 <- liftIO $ Gtk.widgetGetAllocatedHeight canvas - (bbs, hibbs) <- render canvas (draw s rw2 rh2)+ (bbs, hibbs) <- draw s rw2 rh2 - modifyIORef state (\s' -> s' {bounds = bbs, hoverIconBounds = hibbs})+ liftIO $ modifyIORef state (\s' -> s' {bounds = bbs, hoverIconBounds = hibbs}) -- | Export the visualization to an SVG file export :: DrawFunction -> String -> IO ()@@ -146,11 +147,6 @@ ]) return (map trafo result, map toHoverIconBounds result)--render :: WidgetClass w => w -> Render b -> IO b-render canvas r = do- win <- widgetGetDrawWindow canvas- renderWithDrawable win r drawHoverMenu :: Maybe (t, Icon) -> Render Bool drawHoverMenu x = do
src/GHC/Vis/View/List.hs view
@@ -22,8 +22,8 @@ ) where import Graphics.UI.Gtk (PangoRectangle(..), layoutGetExtents, showLayout,- PangoLayout(..), WidgetClass(..), widgetGetAllocation, widgetGetDrawWindow,- renderWithDrawable, widgetQueueDraw, ascent, layoutSetFontDescription,+ PangoLayout, WidgetClass,+ widgetQueueDraw, ascent, layoutSetFontDescription, FontMetrics(..), layoutCopy, layoutSetText, layoutGetContext, fontDescriptionFromString, fontDescriptionSetSize, contextGetLanguage, contextGetMetrics, createLayout)@@ -97,13 +97,14 @@ -- | Draw visualization to screen, called on every update or when it's -- requested from outside the program.-redraw :: WidgetClass w => w -> IO ()+redraw :: WidgetClass w => w -> Render () redraw canvas = do- s <- readIORef state- Gtk.Rectangle _ _ rw2 rh2 <- widgetGetAllocation canvas+ s <- liftIO $ readIORef state+ rw2 <- liftIO $ Gtk.widgetGetAllocatedWidth canvas+ rh2 <- liftIO $ Gtk.widgetGetAllocatedHeight canvas - (size, boundingBoxes) <- render canvas (draw s rw2 rh2)- modifyIORef state (\s' -> s' {totalSize = size, bounds = boundingBoxes})+ (size, boundingBoxes) <- draw s rw2 rh2+ liftIO $ modifyIORef state (\s' -> s' {totalSize = size, bounds = boundingBoxes}) #ifdef SDL_WINDOW getState :: IO State@@ -163,11 +164,6 @@ result <- mapM (drawEntry s maxNameWidth 0) (zip3 objs rpos names) return ((0, 0, sw, sh), map (\(o, (x,y,w,h)) -> (o, (x*sx+ox,y*sy+oy,w*sx,h*sy))) $ concat result)--render :: WidgetClass w => w -> Render b -> IO b-render canvas r = do- win <- widgetGetDrawWindow canvas- renderWithDrawable win r -- | Handle a mouse click. If an object was clicked an 'UpdateSignal' is sent -- that causes the object to be evaluated and the screen to be updated.