diff --git a/Graphics/UI/Gtk.chs b/Graphics/UI/Gtk.chs --- a/Graphics/UI/Gtk.chs +++ b/Graphics/UI/Gtk.chs @@ -194,6 +194,7 @@ module Graphics.UI.Gtk.Misc.HandleBox, module Graphics.UI.Gtk.Misc.IMMulticontext, module Graphics.UI.Gtk.Misc.SizeGroup, + module Graphics.UI.Gtk.Misc.Tooltip, module Graphics.UI.Gtk.Misc.Tooltips, module Graphics.UI.Gtk.Misc.Viewport, -- * Abstract base classes @@ -386,6 +387,7 @@ import Graphics.UI.Gtk.Misc.HandleBox import Graphics.UI.Gtk.Misc.IMMulticontext import Graphics.UI.Gtk.Misc.SizeGroup +import Graphics.UI.Gtk.Misc.Tooltip import Graphics.UI.Gtk.Misc.Tooltips import Graphics.UI.Gtk.Misc.Viewport --import Accessible diff --git a/Graphics/UI/Gtk/Abstract/Container.chs b/Graphics/UI/Gtk/Abstract/Container.chs --- a/Graphics/UI/Gtk/Abstract/Container.chs +++ b/Graphics/UI/Gtk/Abstract/Container.chs @@ -529,8 +529,8 @@ -- %hash c:b3a d:af3f -- | A widget in the container received the input focus. -- -setFocusChild :: ContainerClass self => Signal self (Widget -> IO ()) -setFocusChild = Signal (connect_OBJECT__NONE "set-focus-child") +setFocusChild :: ContainerClass self => Signal self (Maybe Widget -> IO ()) +setFocusChild = Signal (connect_MOBJECT__NONE "set-focus-child") -------------------- -- Deprecated Signals @@ -580,15 +580,15 @@ -- %hash c:1ac6 onSetFocusChild :: ContainerClass self => self - -> (Widget -> IO ()) + -> (Maybe Widget -> IO ()) -> IO (ConnectId self) -onSetFocusChild = connect_OBJECT__NONE "set-focus-child" False +onSetFocusChild = connect_MOBJECT__NONE "set-focus-child" False {-# DEPRECATED onSetFocusChild "instead of 'onSetFocusChild obj' use 'on obj setFocusChild'" #-} -- %hash c:23e5 afterSetFocusChild :: ContainerClass self => self - -> (Widget -> IO ()) + -> (Maybe Widget -> IO ()) -> IO (ConnectId self) -afterSetFocusChild = connect_OBJECT__NONE "set-focus-child" True +afterSetFocusChild = connect_MOBJECT__NONE "set-focus-child" True {-# DEPRECATED afterSetFocusChild "instead of 'afterSetFocusChild obj' use 'after obj setFocusChild'" #-} #endif diff --git a/Graphics/UI/Gtk/Abstract/Widget.chs b/Graphics/UI/Gtk/Abstract/Widget.chs --- a/Graphics/UI/Gtk/Abstract/Widget.chs +++ b/Graphics/UI/Gtk/Abstract/Widget.chs @@ -140,6 +140,11 @@ #if GTK_CHECK_VERSION(2,10,0) widgetInputShapeCombineMask, #endif +#if GTK_CHECK_VERSION(2,12,0) + widgetGetTooltipWindow, + widgetSetTooltipWindow, + widgetTriggerTooltipQuery, +#endif widgetPath, widgetClassPath, widgetGetCompositeName, @@ -197,6 +202,7 @@ widgetGetState, widgetGetSavedState, widgetGetSize, + widgetEvent, -- * Attributes widgetName, @@ -221,6 +227,9 @@ widgetColormap, widgetCompositeName, widgetDirection, + widgetTooltipMarkup, + widgetTooltipText, + widgetHasTooltip, -- * Signals realize, @@ -242,6 +251,7 @@ showHelp, accelClosuresChanged, screenChanged, + queryTooltip, -- * Events buttonPressEvent, @@ -348,7 +358,8 @@ import Control.Monad (liftM, unless) import Data.Maybe (fromMaybe) - +import Control.Monad.Reader (ask) +import Control.Monad.Trans (liftIO) import Data.Bits ((.&.), complement) import System.Glib.FFI import System.Glib.Flags (fromFlags, toFlags) @@ -359,6 +370,7 @@ import System.Glib.GType (GType) import System.Glib.GList (GList, fromGList) import Graphics.UI.Gtk.Abstract.Object (makeNewObject) +import Graphics.Rendering.Pango.Markup {#import Graphics.UI.Gtk.Types#} {#import Graphics.UI.Gtk.Signals#} import Graphics.UI.Gtk.Gdk.Enums (EventMask(..), ExtensionMode(..)) @@ -367,6 +379,7 @@ {#import Graphics.UI.Gtk.Gdk.Pixmap#} (Bitmap) import Graphics.UI.Gtk.General.Structs (Allocation, Rectangle(..) ,Requisition(..), Color, IconSize(..) + ,Point ,widgetGetState, widgetGetSavedState ,widgetGetDrawWindow, widgetGetSize) import Graphics.UI.Gtk.Gdk.Events (Event(..), marshalEvent, @@ -1169,6 +1182,47 @@ (fromIntegral offsetY) #endif +#if GTK_CHECK_VERSION(2,12,0) +-- | Returns the 'Window' of the current tooltip. This can be the 'Window' created by default, or the +-- custom tooltip window set using 'widgetSetTooltipWindow'. +-- +-- * Available since Gtk+ version 2.12 +-- +widgetGetTooltipWindow :: WidgetClass self => self + -> IO Window -- ^ returns The 'Window' of the current tooltip +widgetGetTooltipWindow self = + makeNewObject mkWindow $ + {# call gtk_widget_get_tooltip_window #} + (toWidget self) + +-- | Replaces the default, usually yellow, window used for displaying tooltips with @customWindow@. GTK+ +-- will take care of showing and hiding @customWindow@ at the right moment, to behave likewise as the +-- default tooltip window. If @customWindow@ is 'Nothing', the default tooltip window will be used. +-- +-- If the custom window should have the default theming it needs to have the name 'gtk-tooltip', see +-- 'widgetSetName'. +-- +-- * Available since Gtk+ version 2.12 +-- +widgetSetTooltipWindow :: (WidgetClass self, WindowClass customWindow) => self + -> Maybe customWindow -- ^ @customWindow@ a 'Window', or 'Nothing'. allow-none. + -> IO () +widgetSetTooltipWindow self customWindow = + {# call gtk_widget_set_tooltip_window #} + (toWidget self) + (maybe (Window nullForeignPtr) toWindow customWindow) + +-- | Triggers a tooltip query on the display where the toplevel of @widget@ is +-- located. See 'tooltipTriggerTooltipQuery' for more information. +-- +-- * Available since Gtk+ version 2.12 +-- +widgetTriggerTooltipQuery :: WidgetClass self => self -> IO () +widgetTriggerTooltipQuery self = + {# call gtk_widget_trigger_tooltip_query #} + (toWidget self) +#endif + -- %hash c:7e36 d:616f -- | Obtains the full path to @widget@. The path is simply the name of a -- widget and all its parents in the container hierarchy, separated by periods. @@ -2036,6 +2090,16 @@ peek allocationPtr #endif +-- | Rarely-used function. This function is used to emit the event signals on a widget (those signals +-- should never be emitted without using this function to do so). If you want to synthesize an event +-- though, don't use this function; instead, use 'mainDoEvent' so the event will behave as if it +-- were in the event queue. Don't synthesize expose events; instead, use 'windowInvalidateRect' +-- to invalidate a region of the window. +widgetEvent :: WidgetClass self => self -> EventM t Bool +widgetEvent widget = do + ptr <- ask + liftIO $ liftM toBool $ {#call widget_event #} (toWidget widget) (castPtr ptr) + -------------------- -- Attributes @@ -2223,6 +2287,50 @@ widgetGetDirection widgetSetDirection +-- | Sets the text of tooltip to be the given string, which is marked up with the Pango text markup +-- language. Also see 'tooltipSetMarkup'. +-- +-- This is a convenience property which will take care of getting the tooltip shown if the given string +-- is not \"\": 'hasTooltip' will automatically be set to 'True' and there will be taken care of +-- 'queryTooltip' in the default signal handler. +-- +-- Default value: \"\" +-- +-- * Available since Gtk+ version 2.12 +-- +widgetTooltipMarkup :: WidgetClass self => Attr self (Maybe Markup) +widgetTooltipMarkup = newAttrFromMaybeStringProperty "tooltip-markup" + +-- | Sets the text of tooltip to be the given string. +-- +-- Also see 'tooltipSetText'. +-- +-- This is a convenience property which will take care of getting the tooltip shown if the given string +-- is not \"\": 'hasTooltip' will automatically be set to 'True' and there will be taken care of +-- 'queryTooltip' in the default signal handler. +-- +-- Default value: \"\" +-- +-- * Available since Gtk+ version 2.12 +-- +widgetTooltipText :: WidgetClass self => Attr self (Maybe String) +widgetTooltipText = newAttrFromMaybeStringProperty "tooltip-text" + +-- | Enables or disables the emission of 'queryTooltip' on widget. A value of 'True' indicates that widget +-- can have a tooltip, in this case the widget will be queried using 'queryTooltip' to determine +-- whether it will provide a tooltip or not. +-- +-- Note that setting this property to 'True' for the first time will change the event masks of the +-- 'Windows' of this widget to include leave-notify and motion-notify events. This cannot and will not +-- be undone when the property is set to 'False' again. +-- +-- Default value: 'False' +-- +-- * Available since Gtk+ version 2.12 +-- +widgetHasTooltip :: WidgetClass self => Attr self Bool +widgetHasTooltip = newAttrFromBoolProperty "has-tooltip" + -------------------- -- Signals @@ -2374,6 +2482,24 @@ -- screenChanged :: WidgetClass self => Signal self (Screen -> IO ()) screenChanged = Signal (connect_OBJECT__NONE "screen_changed") + +-- | Emitted when 'hasTooltip' is 'True' and the 'gtkTooltipTimeout' has expired with the cursor +-- hovering "above" widget; or emitted when widget got focus in keyboard mode. +-- +-- Using the given coordinates, the signal handler should determine whether a tooltip should be shown +-- for widget. If this is the case 'True' should be returned, 'False' otherwise. +-- Note if widget got focus in keyboard mode, 'Point' is 'Nothing'. +-- +-- The signal handler is free to manipulate tooltip with the therefore destined function calls. +-- +-- * Available since Gtk+ version 2.12 +-- +queryTooltip :: WidgetClass self => Signal self (Widget -> Maybe Point -> Tooltip -> IO Bool) +queryTooltip = + Signal (\after model user -> + connect_OBJECT_INT_INT_BOOL_OBJECT__BOOL "query_tooltip" + after model (\widget x y keyb tooltip -> + user widget (if keyb then Nothing else Just (x, y)) tooltip)) -- * Events -- diff --git a/Graphics/UI/Gtk/Builder.chs b/Graphics/UI/Gtk/Builder.chs --- a/Graphics/UI/Gtk/Builder.chs +++ b/Graphics/UI/Gtk/Builder.chs @@ -82,8 +82,10 @@ , builderNew , builderAddFromFile , builderAddFromString +#if GTK_CHECK_VERSION(2,14,0) , builderAddObjectsFromFile , builderAddObjectsFromString +#endif -- * Retrieving objects , builderGetObject @@ -144,6 +146,7 @@ builder strPtr (fromIntegral strLen) errPtrPtr >> return () +#if GTK_CHECK_VERSION(2,14,0) -- | Parses a file containing a GtkBuilder UI definition building only -- the requested objects and merges them with the current contents of -- the 'Builder'. @@ -185,6 +188,7 @@ {# call unsafe builder_add_objects_from_string #} builder strPtr (fromIntegral strLen) idsPtr errPtrPtr >> return () +#endif --------------------------------------- -- Retrieving objects diff --git a/Graphics/UI/Gtk/Cairo.chs b/Graphics/UI/Gtk/Cairo.chs --- a/Graphics/UI/Gtk/Cairo.chs +++ b/Graphics/UI/Gtk/Cairo.chs @@ -18,6 +18,8 @@ -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- Lesser General Public License for more details. -- +-- #hide + -- | -- Maintainer : gtk2hs-users@lists.sourceforge.net -- Stability : provisional @@ -69,17 +71,7 @@ import System.Glib.FFI {#import Graphics.UI.Gtk.Types#} {#import Graphics.UI.Gtk.Gdk.Region#} (Region(..)) -import Graphics.UI.Gtk.General.Structs (Color(..)) -import System.Glib.GObject (constructNewGObject, makeNewGObject, - objectRef, objectUnref) -{#import Graphics.Rendering.Pango.Types#} -{#import Graphics.Rendering.Pango.BasicTypes#} -import Graphics.Rendering.Pango.Structs ( pangoItemGetFont ) -{#import Graphics.Rendering.Pango.Layout#} ( layoutSetText ) -{#import Graphics.UI.Gtk.Gdk.Pixbuf#} ( pixbufGetHasAlpha, pixbufGetNChannels, - pixbufGetColorSpace, pixbufGetWidth, pixbufGetHeight, pixbufGetRowstride, - Colorspace(..) ) -import Data.IORef +{#import Graphics.Rendering.Pango.Cairo#} #if GTK_CHECK_VERSION(2,8,0) {#import Graphics.Rendering.Cairo.Types#} as Cairo @@ -109,15 +101,6 @@ fail =<< Cairo.Internal.statusToString status) (\context -> runReaderT (Cairo.Internal.runRender m) context) --- | Sets the specified 'Color' as the source color of the 'Render' context. --- -setSourceColor :: Color -> Render () -setSourceColor (Color red green blue) = - Cairo.setSourceRGB - (realToFrac red / 65535.0) - (realToFrac green / 65535.0) - (realToFrac blue / 65535.0) - -- | Sets the given pixbuf as the source pattern for the Cairo context. The -- pattern has an extend mode of 'ExtendNone' and is aligned so that the -- origin of pixbuf is @(x, y)@. @@ -143,209 +126,4 @@ liftIO $ {# call unsafe gdk_cairo_region #} cr region - - --- cairo_font_map_new cannot be bound due to incorrect memory management --- in functions like font_map_list_families that create new structures --- that store the font map without referencing them - --- | Retrieve the default 'Graphics.UI.Gtk.Pango.FontMap' that contains a --- list of available fonts. --- --- * One purpose of creating an explicit --- 'Graphics.UI.Gtk.Pango.Font.FontMap' is to set --- a different scaling factor between font sizes (in points, pt) and --- Cairo units (in pixels). The default is 96dpi (dots per inch) which --- corresponds to an average screen as output medium. A 10pt font will --- therefore scale to --- @10pt * (1\/72 pt\/inch) * (96 pixel\/inch) = 13.3 pixel@. --- -cairoFontMapGetDefault :: IO FontMap -cairoFontMapGetDefault = - makeNewGObject mkFontMap $ {#call unsafe pango_cairo_font_map_get_default#} - --- | Set the scaling factor between font size and Cairo units. --- --- * Value is in dots per inch (dpi). See 'cairoFontMapNew'. --- -cairoFontMapSetResolution :: FontMap -> Double -> IO () -cairoFontMapSetResolution (FontMap fm) dpi = - withForeignPtr fm $ \fmPtr -> - {#call unsafe pango_cairo_font_map_set_resolution#} - (castPtr fmPtr) (realToFrac dpi) - --- | Ask for the scaling factor between font size and Cairo units. --- --- * Value is in dots per inch (dpi). See 'cairoFontMapNew'. --- -cairoFontMapGetResolution :: FontMap -> IO Double -cairoFontMapGetResolution (FontMap fm) = liftM realToFrac $ - withForeignPtr fm $ \fmPtr -> - {#call unsafe pango_cairo_font_map_get_resolution#} (castPtr fmPtr) - --- | Create a 'PangoContext'. --- --- * If no 'FontMap' is specified, it uses the default 'FontMap' that --- has a scaling factor of 96 dpi. See 'cairoFontMapNew'. --- -cairoCreateContext :: Maybe FontMap -> IO PangoContext -cairoCreateContext (Just (FontMap fm)) = constructNewGObject mkPangoContext $ - withForeignPtr fm $ \fmPtr -> -- PangoCairoFontMap /= PangoFontMap - {#call unsafe pango_cairo_font_map_create_context#} (castPtr fmPtr) -cairoCreateContext Nothing = do - fmPtr <- {#call unsafe pango_cairo_font_map_get_default#} - constructNewGObject mkPangoContext $ - {#call unsafe pango_cairo_font_map_create_context#} (castPtr fmPtr) - --- | Set the scaling factor of the 'PangoContext'. --- --- * Supplying zero or a negative value will result in the resolution value --- of the underlying 'FontMap' to be used. See also 'cairoFontMapNew'. --- -cairoContextSetResolution :: PangoContext -> Double -> IO () -cairoContextSetResolution pc dpi = - {#call unsafe pango_cairo_context_set_resolution#} pc (realToFrac dpi) - --- | Ask for the scaling factor of the 'PangoContext'. --- --- * A negative value will be returned if no resolution has been set. --- See 'cairoContextSetResolution'. --- -cairoContextGetResolution :: PangoContext -> IO Double -cairoContextGetResolution pc = liftM realToFrac $ - {#call unsafe pango_cairo_context_get_resolution#} pc - --- | Set Cairo font options. --- --- * Apply the given font options to the context. Values set through this --- functions override those that are set by 'updateContext'. --- -cairoContextSetFontOptions :: PangoContext -> FontOptions -> IO () -cairoContextSetFontOptions pc fo = - {#call unsafe pango_cairo_context_set_font_options#} pc fo - --- | Reset Cairo font options. --- -cairoContextResetFontOptions :: PangoContext -> IO () -cairoContextResetFontOptions pc = - {#call unsafe pango_cairo_context_set_font_options#} pc - (Cairo.Internal.FontOptions nullForeignPtr) - --- | Retrieve Cairo font options. --- -cairoContextGetFontOptions :: PangoContext -> IO FontOptions -cairoContextGetFontOptions pc = do - foPtr <- {#call unsafe pango_cairo_context_get_font_options#} pc - Cairo.Internal.mkFontOptions foPtr - --- | Update a 'PangoContext' with respect to changes in a 'Render' --- environment. --- --- * The 'PangoContext' must have been created with --- 'cairoCreateContext'. Any 'PangoLayout's that have been --- previously created with this context have to be update using --- 'Graphics.UI.Gtk.Pango.Layout.layoutContextChanged'. --- -updateContext :: PangoContext -> Render () -updateContext pc = Render $ do - cr <- ask - liftIO $ {# call unsafe pango_cairo_update_context #} cr pc - --- | Create a 'PangoLayout' within a 'Render' context. --- --- * This is a convenience function that creates a new 'PangoContext' --- within this 'Render' context and creates a new 'PangoLayout'. --- If the transformation or target surface of the 'Render' context --- change, 'updateLayout' has to be called on this layout. --- -createLayout :: String -> Render PangoLayout -createLayout text = Render $ do - cr <- ask - liftIO $ do - layRaw <- constructNewGObject mkPangoLayoutRaw $ - {#call unsafe pango_cairo_create_layout#} cr - textRef <- newIORef undefined - let pl = (PangoLayout textRef layRaw) - layoutSetText pl text - return pl - --- | Propagate changed to the 'Render' context to a 'PangoLayout'. --- --- * This is a convenience function that calls 'updateContext' on the --- (private) 'PangoContext' of the given layout to propagate changes --- from the 'Render' context to the 'PangoContext' and then calls --- 'Graphics.UI.Gtk.Pango.Layout.layoutContextChanged' on the layout. --- This function is necessary for --- 'createLayout' since a private 'PangoContext' is created that is --- not visible to the user. --- -updateLayout :: PangoLayout -> Render () -updateLayout (PangoLayout _ lay) = Render $ do - cr <- ask - liftIO $ {#call unsafe pango_cairo_update_layout#} cr lay - --- | Draw a glyph string. --- --- * The origin of the glyphs (the left edge of the baseline) will be drawn --- at the current point of the cairo context. --- -showGlyphString :: GlyphItem -> Render () -showGlyphString (GlyphItem pi gs) = Render $ do - cr <- ask - font <- liftIO $ pangoItemGetFont pi - liftIO $ {#call unsafe pango_cairo_show_glyph_string#} cr font gs - --- | Draw a 'LayoutLine'. --- --- * The origin of the glyphs (the left edge of the baseline) will be drawn --- at the current point of the cairo context. --- -showLayoutLine :: LayoutLine -> Render () -showLayoutLine (LayoutLine _ ll) = Render $ do - cr <- ask - liftIO $ {#call unsafe pango_cairo_show_layout_line#} cr ll - --- | Draw a 'PangoLayout'. --- --- * The top-left corner of the 'PangoLayout' will be drawn at the current --- point of the cairo context. --- -showLayout :: PangoLayout -> Render () -showLayout (PangoLayout _ lay) = Render $ do - cr <- ask - liftIO $ {#call unsafe pango_cairo_show_layout#} cr lay - - --- | Add the extent of a glyph string to the current path. --- --- * The origin of the glyphs (the left edge of the line) will be at the --- current point of the cairo context. --- -glyphStringPath :: GlyphItem -> Render () -glyphStringPath (GlyphItem pi gs) = Render $ do - cr <- ask - font <- liftIO $ pangoItemGetFont pi - liftIO $ {#call unsafe pango_cairo_glyph_string_path#} cr font gs - --- | Add the extent of a layout line to the current path. --- --- * The origin of the glyphs (the left edge of the line) will be at the --- current point of the cairo context. --- -layoutLinePath :: LayoutLine -> Render () -layoutLinePath (LayoutLine _ ll) = Render $ do - cr <- ask - liftIO $ {#call unsafe pango_cairo_layout_line_path#} cr ll - --- | Add the layout to the current path. --- --- * Adds the top-left corner of the text to the current path. Afterwards, --- the path position is at the bottom-right corner of the 'PangoLayout'. --- -layoutPath :: PangoLayout -> Render () -layoutPath (PangoLayout _ lay) = Render $ do - cr <- ask - liftIO $ {#call unsafe pango_cairo_layout_path#} cr lay - #endif - diff --git a/Graphics/UI/Gtk/Gdk/DrawWindow.chs b/Graphics/UI/Gtk/Gdk/DrawWindow.chs --- a/Graphics/UI/Gtk/Gdk/DrawWindow.chs +++ b/Graphics/UI/Gtk/Gdk/DrawWindow.chs @@ -53,6 +53,7 @@ fromNativeWindowId, -- * Methods drawWindowGetState, + drawWindowScroll, drawWindowClear, drawWindowClearArea, drawWindowClearAreaExpose, @@ -77,7 +78,8 @@ drawWindowGetPointer, drawWindowGetPointerPos, drawWindowGetOrigin, - drawWindowForeignNew + drawWindowForeignNew, + drawWindowGetDefaultRootWindow, ) where import Control.Monad (liftM) @@ -555,3 +557,10 @@ drawWindowForeignNew :: NativeWindowId -> IO (Maybe DrawWindow) drawWindowForeignNew anid = maybeNull (makeNewGObject mkDrawWindow) $ liftM castPtr $ {#call gdk_window_foreign_new#} (fromNativeWindowId anid) + +-- | Obtains the root window (parent all other windows are inside) for the default display and screen. +drawWindowGetDefaultRootWindow :: + IO DrawWindow -- ^ returns the default root window +drawWindowGetDefaultRootWindow = + makeNewGObject mkDrawWindow $ + {#call gdk_get_default_root_window #} diff --git a/Graphics/UI/Gtk/Gdk/Drawable.chs b/Graphics/UI/Gtk/Gdk/Drawable.chs --- a/Graphics/UI/Gtk/Gdk/Drawable.chs +++ b/Graphics/UI/Gtk/Gdk/Drawable.chs @@ -43,6 +43,7 @@ drawableGetSize, drawableGetClipRegion, drawableGetVisibleRegion, + drawableGetID, Point, drawPoint, drawPoints, @@ -61,12 +62,13 @@ drawLayoutLineWithColors, drawLayout, drawLayoutWithColors, - drawDrawable) where + drawDrawable, +) where import Control.Monad (liftM) import System.Glib.FFI -import Graphics.UI.Gtk.General.Structs (Point, Color) +import Graphics.UI.Gtk.General.Structs (Point, Color, drawableGetID) import Graphics.Rendering.Pango.Structs {#import Graphics.Rendering.Pango.Types#} {#import Graphics.Rendering.Pango.BasicTypes#} diff --git a/Graphics/UI/Gtk/Gdk/EventM.hsc b/Graphics/UI/Gtk/Gdk/EventM.hsc --- a/Graphics/UI/Gtk/Gdk/EventM.hsc +++ b/Graphics/UI/Gtk/Gdk/EventM.hsc @@ -29,9 +29,7 @@ -- Stability : provisional -- Portability : portable (depends on GHC) -- --- Types and accessors to examine information in events. This module is not --- exposed by default and therefore has to be imported explicitly using: --- @import Graphics.UI.Gtk.Gdk.EventM@ +-- Types and accessors to examine information in events. -- module Graphics.UI.Gtk.Gdk.EventM ( -- * Detail diff --git a/Graphics/UI/Gtk/Gdk/Events.hsc b/Graphics/UI/Gtk/Gdk/Events.hsc --- a/Graphics/UI/Gtk/Gdk/Events.hsc +++ b/Graphics/UI/Gtk/Gdk/Events.hsc @@ -28,7 +28,7 @@ -- Portability : portable (depends on GHC) -- -- Definiton of a record that contains event information. Deprecated in --- favor of 'Graphics.UI.Gtk.Gdk.EventM'. +-- favor of 'Graphics.UI.Gtk.Gdk.EventM' and not exported by Gtk.hs. -- module Graphics.UI.Gtk.Gdk.Events ( Modifier(..), -- a mask of control keys diff --git a/Graphics/UI/Gtk/General/Clipboard.chs b/Graphics/UI/Gtk/General/Clipboard.chs --- a/Graphics/UI/Gtk/General/Clipboard.chs +++ b/Graphics/UI/Gtk/General/Clipboard.chs @@ -405,8 +405,7 @@ cbRef <- newIORef nullFunPtr cbPtr <- mkClipboardReceivedFunc (\_ sPtr -> do - cbPtr <- readIORef cbRef - freeHaskellFunPtr cbPtr + freeHaskellFunPtr =<< readIORef cbRef runReaderT callback sPtr return ()) writeIORef cbRef cbPtr @@ -438,16 +437,18 @@ -- way or the other.) -> IO () clipboardRequestText self callback = do + cbRef <- newIORef nullFunPtr cbPtr <- mkClipboardTextReceivedFunc (\_ sPtr -> do + freeHaskellFunPtr =<< readIORef cbRef mStr <- if sPtr==nullPtr then return Nothing else liftM Just $ peekUTFString sPtr callback mStr) + writeIORef cbRef cbPtr {# call gtk_clipboard_request_text #} (toClipboard self) cbPtr nullPtr - freeHaskellFunPtr cbPtr {#pointer ClipboardTextReceivedFunc#} @@ -474,15 +475,17 @@ -- called one way or the other.) -> IO () clipboardRequestImage self callback = do + cbRef <- newIORef nullFunPtr cbPtr <- mkClipboardImageReceivedFunc (\_ sPtr -> do + freeHaskellFunPtr =<< readIORef cbRef mPixbuf <- maybeNull (makeNewGObject mkPixbuf) (return sPtr) callback mPixbuf) + writeIORef cbRef cbPtr {# call gtk_clipboard_request_image #} (toClipboard self) cbPtr nullPtr - freeHaskellFunPtr cbPtr {#pointer ClipboardImageReceivedFunc#} @@ -508,16 +511,19 @@ -- be called one way or the other.) -> IO () clipboardRequestTargets self callback = do + cbRef <- newIORef nullFunPtr cbPtr <- mkClipboardTargetsReceivedFunc (\_ tPtr len -> do + -- We must free Haskell pointer *in* the callback to avoid segfault. + freeHaskellFunPtr =<< readIORef cbRef mTargets <- if tPtr==nullPtr then return Nothing else liftM (Just . map Atom) $ peekArray (fromIntegral len) tPtr callback mTargets) + writeIORef cbRef cbPtr {# call gtk_clipboard_request_targets #} (toClipboard self) cbPtr nullPtr - freeHaskellFunPtr cbPtr {#pointer ClipboardTargetsReceivedFunc#} @@ -544,18 +550,20 @@ -- called one way or the other.) -> IO () clipboardRequestRichText self buffer callback = do + cbRef <- newIORef nullFunPtr cbPtr <- mkClipboardRichTextReceivedFunc (\_ tPtr sPtr len -> do + freeHaskellFunPtr =<< readIORef cbRef mRes <- if sPtr==nullPtr then return Nothing else liftM Just $ do str <- peekUTFStringLen (sPtr,fromIntegral len) return (Atom tPtr, str) callback mRes) + writeIORef cbRef cbPtr {# call gtk_clipboard_request_rich_text #} (toClipboard self) (toTextBuffer buffer) cbPtr nullPtr - freeHaskellFunPtr cbPtr {#pointer ClipboardRichTextReceivedFunc#} diff --git a/Graphics/UI/Gtk/General/General.chs b/Graphics/UI/Gtk/General/General.chs --- a/Graphics/UI/Gtk/General/General.chs +++ b/Graphics/UI/Gtk/General/General.chs @@ -49,6 +49,7 @@ mainLevel, mainIteration, mainIterationDo, + mainDoEvent, -- * Grab widgets grabAdd, @@ -69,8 +70,9 @@ idleRemove, inputAdd, inputRemove, - IOCondition, - HandlerId + IOCondition(..), + HandlerId, + FD ) where import System.Environment (getProgName, getArgs) @@ -81,8 +83,14 @@ import System.Glib.FFI import System.Glib.UTFString -import System.Glib.MainLoop +import qualified System.Glib.MainLoop as ML +import System.Glib.MainLoop ( Priority, priorityLow, priorityDefaultIdle, + priorityHighIdle, priorityDefault, priorityHigh, timeoutRemove, idleRemove, + inputRemove, IOCondition(..), HandlerId ) import Graphics.UI.Gtk.Abstract.Object (makeNewObject) +import Graphics.UI.Gtk.Gdk.EventM (EventM) +import Control.Monad.Reader (ask) +import Control.Monad.Trans (liftIO) {#import Graphics.UI.Gtk.Types#} {#context lib="gtk" prefix ="gtk"#} @@ -121,7 +129,7 @@ -- -- -- * If you want to use Gtk2Hs and in a multi-threaded application then it is your obligation --- to ensure that all calls to Gtk+ happen on a single OS thread. +-- to ensure that all calls to Gtk+ happen in a single OS thread. -- If you want to make calls to Gtk2Hs functions from a Haskell thread other -- than the one that calls this functions and 'mainGUI' then you will have to -- \'post\' your GUI actions to the main GUI thread. You can do this using @@ -130,7 +138,7 @@ initGUI :: IO [String] initGUI = do when rtsSupportsBoundThreads initialiseGThreads - threadsEnter + -- note: initizliseGThreads calls 'threadsEnter' prog <- getProgName args <- getArgs let allArgs = (prog:args) @@ -173,7 +181,7 @@ idleAdd (action >> return False) priorityDefault return () --- | Acquired the global Gtk lock. +-- | Acquire the global Gtk lock. -- -- * During normal operation, this lock is held by the thread from which all -- interaction with Gtk is performed. When calling 'mainGUI', the thread will @@ -243,6 +251,45 @@ mainIterationDo blocking = liftM toBool $ {#call main_iteration_do#} (fromBool blocking) +-- | Processes a single GDK event. This is public only to allow filtering of events between GDK and +-- GTK+. You will not usually need to call this function directly. +-- +-- While you should not call this function directly, you might want to know how exactly events are +-- handled. So here is what this function does with the event: +-- +-- 1. Compress enter/leave notify events. If the event passed build an enter/leave pair together with +-- the next event (peeked from GDK) both events are thrown away. This is to avoid a backlog of +-- (de-)highlighting widgets crossed by the pointer. +-- +-- 2. Find the widget which got the event. If the widget can't be determined the event is thrown away +-- unless it belongs to a INCR transaction. In that case it is passed to +-- 'selectionIncrEvent'. +-- +-- 3. Then the event is passed on a stack so you can query the currently handled event with +-- 'getCurrentEvent'. +-- +-- 4. The event is sent to a widget. If a grab is active all events for widgets that are not in the +-- contained in the grab widget are sent to the latter with a few exceptions: +-- +-- * Deletion and destruction events are still sent to the event widget for obvious reasons. +-- +-- * Events which directly relate to the visual representation of the event widget. +-- +-- * Leave events are delivered to the event widget if there was an enter event delivered to it +-- before without the paired leave event. +-- +-- * Drag events are not redirected because it is unclear what the semantics of that would be. +-- +-- Another point of interest might be that all key events are first passed through the key snooper +-- functions if there are any. Read the description of 'keySnooperInstall' if you need this +-- feature. +-- +-- 5. After finishing the delivery the event is popped from the event stack. +mainDoEvent :: EventM t () +mainDoEvent = do + ptr <- ask + liftIO $ {#call main_do_event #} (castPtr ptr) + -- | add a grab widget -- grabAdd :: WidgetClass wd => wd -> IO () @@ -260,3 +307,75 @@ -- grabRemove :: WidgetClass w => w -> IO () grabRemove = {#call grab_remove#} . toWidget + +-- | Sets a function to be called at regular intervals, with the default +-- priority 'priorityDefault'. The function is called repeatedly until it +-- returns @False@, after which point the timeout function will not be called +-- again. The first call to the function will be at the end of the first interval. +-- +-- Note that timeout functions may be delayed, due to the processing of other +-- event sources. Thus they should not be relied on for precise timing. After +-- each call to the timeout function, the time of the next timeout is +-- recalculated based on the current time and the given interval (it does not +-- try to 'catch up' time lost in delays). +-- +-- This function differs from 'ML.timeoutAdd' in that the action will +-- be executed within the global Gtk+ lock. It is therefore possible to +-- call Gtk+ functions from the action. +-- +timeoutAdd :: IO Bool -> Int -> IO HandlerId +timeoutAdd fun msec = timeoutAddFull fun priorityDefault msec + +-- | Sets a function to be called at regular intervals, with the given +-- priority. The function is called repeatedly until it returns @False@, after +-- which point the timeout function will not be called again. The first call +-- to the function will be at the end of the first interval. +-- +-- Note that timeout functions may be delayed, due to the processing of other +-- event sources. Thus they should not be relied on for precise timing. After +-- each call to the timeout function, the time of the next timeout is +-- recalculated based on the current time and the given interval (it does not +-- try to 'catch up' time lost in delays). +-- +-- This function differs from 'ML.timeoutAddFull' in that the action will +-- be executed within the global Gtk+ lock. It is therefore possible to +-- call Gtk+ functions from the action. +-- +timeoutAddFull :: IO Bool -> Priority -> Int -> IO HandlerId +timeoutAddFull fun pri msec = + ML.timeoutAddFull (threadsEnter >> fun >>= \r -> threadsLeave >> return r) + pri msec + +-- | Add a callback that is called whenever the system is idle. +-- +-- * A priority can be specified via an integer. This should usually be +-- 'priorityDefaultIdle'. +-- +-- * If the function returns @False@ it will be removed. +-- +-- This function differs from 'ML.idleAdd' in that the action will +-- be executed within the global Gtk+ lock. It is therefore possible to +-- call Gtk+ functions from the action. +-- +idleAdd :: IO Bool -> Priority -> IO HandlerId +idleAdd fun pri = + ML.idleAdd (threadsEnter >> fun >>= \r -> threadsLeave >> return r) pri + +type FD = Int + +-- | Adds the file descriptor into the main event loop with the given priority. +-- +-- This function differs from 'ML.inputAdd' in that the action will +-- be executed within the global Gtk+ lock. It is therefore possible to +-- call Gtk+ functions from the action. +-- +inputAdd :: + FD -- ^ a file descriptor + -> [IOCondition] -- ^ the condition to watch for + -> Priority -- ^ the priority of the event source + -> IO Bool -- ^ the function to call when the condition is satisfied. + -- The function should return False if the event source + -- should be removed. + -> IO HandlerId -- ^ the event source id +inputAdd fd conds pri fun = + ML.inputAdd fd conds pri (threadsEnter >> fun >>= \r -> threadsLeave >> return r) diff --git a/Graphics/UI/Gtk/General/IconTheme.chs b/Graphics/UI/Gtk/General/IconTheme.chs --- a/Graphics/UI/Gtk/General/IconTheme.chs +++ b/Graphics/UI/Gtk/General/IconTheme.chs @@ -41,15 +41,15 @@ -- Named icons are similar to the Themeable Stock Images facility, and the distinction between the -- two may be a bit confusing. A few things to keep in mind: -- --- ● Stock images usually are used in conjunction with Stock Items, such as ''StockOk'' or +-- * Stock images usually are used in conjunction with Stock Items, such as ''StockOk'' or -- ''StockOpen''. Named icons are easier to set up and therefore are more useful for new icons -- that an application wants to add, such as application icons or window icons. -- --- ● Stock images can only be loaded at the symbolic sizes defined by the 'IconSize' enumeration, or +-- * Stock images can only be loaded at the symbolic sizes defined by the 'IconSize' enumeration, or -- by custom sizes defined by 'iconSizeRegister', while named icons are more flexible and any -- pixel size can be specified. -- --- ● Because stock images are closely tied to stock items, and thus to actions in the user interface, +-- * Because stock images are closely tied to stock items, and thus to actions in the user interface, -- stock images may come in multiple variants for different widget states or writing directions. -- -- A good rule of thumb is that if there is a stock image for what you want to use, use it, otherwise @@ -64,9 +64,8 @@ -- use the standard icon theme for the 'Screen' so that the icon information is shared with other -- people looking up icons. In the case where the default screen is being used, looking up an icon can -- be as simple as: --- + -- * Class Hierarchy --- -- | -- @ -- | 'GObject' diff --git a/Graphics/UI/Gtk/General/Structs.hsc b/Graphics/UI/Gtk/General/Structs.hsc --- a/Graphics/UI/Gtk/General/Structs.hsc +++ b/Graphics/UI/Gtk/General/Structs.hsc @@ -51,12 +51,13 @@ ResponseId(..), fromResponse, toResponse, - #if !defined(WIN32) || GTK_CHECK_VERSION(2,8,0) +#if !defined(WIN32) || GTK_CHECK_VERSION(2,8,0) NativeWindowId, toNativeWindowId, fromNativeWindowId, nativeWindowIdNone, - #endif +#endif + drawableGetID, #ifndef DISABLE_DEPRECATED toolbarChildButton, toolbarChildToggleButton, @@ -592,6 +593,26 @@ nativeWindowIdNone = NativeWindowId 0 #endif #endif + +#if !defined(WIN32) +foreign import ccall unsafe "gdk_x11_drawable_get_xid" + gdk_x11_drawable_get_xid :: (Ptr Drawable) -> IO CInt +#else +foreign import ccall unsafe "gdk_win32_drawable_get_handle" + gdk_win32_drawable_get_handle :: (Ptr Drawable) -> IO (Ptr a) +#endif + +-- | Get 'NativeWindowId' of 'Drawable'. +drawableGetID :: DrawableClass d => d -> IO NativeWindowId +drawableGetID d = + liftM toNativeWindowId $ + (\(Drawable drawable) -> +#if !defined(WIN32) + withForeignPtr drawable gdk_x11_drawable_get_xid +#else + withForeignPtr drawable gdk_win32_drawable_get_handle +#endif + ) (toDrawable d) #ifndef DISABLE_DEPRECATED -- Static values for different Toolbar widgets. diff --git a/Graphics/UI/Gtk/General/hsgthread.c b/Graphics/UI/Gtk/General/hsgthread.c --- a/Graphics/UI/Gtk/General/hsgthread.c +++ b/Graphics/UI/Gtk/General/hsgthread.c @@ -34,13 +34,13 @@ #include #endif -#undef DEBUG +#define DEBUG static int threads_initialised = 0; #if defined( WIN32 ) static CRITICAL_SECTION gtk2hs_finalizer_mutex; #else -static GStaticMutex gtk2hs_finalizer_mutex = G_STATIC_MUTEX_INIT; +static GStaticMutex gtk2hs_finalizer_mutex; #endif static GSource* gtk2hs_finalizer_source; static guint gtk2hs_finalizer_id; @@ -51,13 +51,24 @@ /* Initialize the threads system of Gdk and Gtk. */ void gtk2hs_threads_initialise (void) { +#ifdef DEBUG + printf("gtk2hs_threads_initialise: threads_initialised=%i, g_thread_get_initialized=%i\n", + threads_initialised, g_thread_get_initialized()); +#endif + if (!threads_initialised) { threads_initialised = 1; #if defined( WIN32 ) InitializeCriticalSection(>k2hs_finalizer_mutex); +#else + g_static_mutex_init(>k2hs_finalizer_mutex); #endif g_thread_init(NULL); gdk_threads_init(); + + /* from here onwards, the Gdk lock is held */ + gdk_threads_enter(); + } } @@ -66,6 +77,12 @@ int mutex_locked = 0; if (threads_initialised) { +#ifdef DEBUG + printf("acquiring lock to add a %s object at %lx\n", + g_type_name(G_OBJECT_TYPE(object)), (unsigned long) object); + printf("value of lock function is %lx\n", + (unsigned long) g_thread_functions_for_glib_use.mutex_lock); +#endif #if defined( WIN32 ) EnterCriticalSection(>k2hs_finalizer_mutex); #else @@ -75,7 +92,8 @@ } #ifdef DEBUG - printf("adding finalizer!\n"); + if (mutex_locked) printf("within mutex: "); + printf("adding finalizer to a %s object!\n", g_type_name(G_OBJECT_TYPE(object))); #endif /* Ensure that the idle handler is still installed and that @@ -84,8 +102,14 @@ if (gtk2hs_finalizers == NULL) gtk2hs_finalizers = g_array_new(0, 0, sizeof(gpointer)); +#ifdef DEBUG + printf("creating finalizer list.\n"); +#endif if (gtk2hs_finalizer_source != NULL) { +#ifdef DEBUG + printf("re-initializing finalizer source.\n"); +#endif g_source_destroy(gtk2hs_finalizer_source); g_source_unref(gtk2hs_finalizer_source); }; @@ -100,6 +124,10 @@ g_array_append_val(gtk2hs_finalizers, object); if (mutex_locked) { +#ifdef DEBUG + printf("releasing lock to add a %s object at %lx\n", + g_type_name(G_OBJECT_TYPE(object)), (unsigned long) object); +#endif #if defined( WIN32 ) LeaveCriticalSection(>k2hs_finalizer_mutex); #else @@ -113,8 +141,13 @@ gint index; g_assert(gtk2hs_finalizers!=NULL); + gdk_threads_enter(); + int mutex_locked = 0; if (threads_initialised) { +#ifdef DEBUG + printf("acquiring lock to kill objects\n"); +#endif #if defined( WIN32 ) EnterCriticalSection(>k2hs_finalizer_mutex); #else @@ -135,12 +168,17 @@ gtk2hs_finalizer_id = 0; if (mutex_locked) { +#ifdef DEBUG + printf("releasing lock to kill objects\n"); +#endif #if defined( WIN32 ) LeaveCriticalSection(>k2hs_finalizer_mutex); #else g_static_mutex_unlock(>k2hs_finalizer_mutex); #endif } + + gdk_threads_leave(); return FALSE; } diff --git a/Graphics/UI/Gtk/MenuComboToolbar/MenuToolButton.chs b/Graphics/UI/Gtk/MenuComboToolbar/MenuToolButton.chs --- a/Graphics/UI/Gtk/MenuComboToolbar/MenuToolButton.chs +++ b/Graphics/UI/Gtk/MenuComboToolbar/MenuToolButton.chs @@ -66,6 +66,10 @@ menuToolButtonSetMenu, menuToolButtonGetMenu, menuToolButtonSetArrowTooltip, +#if GTK_CHECK_VERSION(2,12,0) + menuToolButtonSetArrowTooltipText, + menuToolButtonSetArrowTooltipMarkup, +#endif -- * Attributes menuToolButtonMenu, @@ -85,6 +89,7 @@ {#import Graphics.UI.Gtk.Types#} {#import Graphics.UI.Gtk.Signals#} import Graphics.UI.Gtk.General.StockItems +import Graphics.Rendering.Pango.Markup {# context lib="gtk" prefix="gtk" #} @@ -162,6 +167,40 @@ tooltips tipTextPtr tipPrivatePtr + +#if GTK_CHECK_VERSION(2,12,0) +-- | Sets the tooltip text to be used as tooltip for the arrow button which +-- pops up the menu. See 'toolItemSetTooltip' for setting a tooltip on the +-- whole 'MenuToolButton'. +-- +-- * Available since Gtk+ version 2.12 +-- +menuToolButtonSetArrowTooltipText :: MenuToolButtonClass self => self + -> String -- ^ @text@ - text to be used as tooltip text for button's arrow + -- button + -> IO () +menuToolButtonSetArrowTooltipText self text = + withUTFString text $ \textPtr -> + {# call gtk_menu_tool_button_set_arrow_tooltip_text #} + (toMenuToolButton self) + textPtr + +-- | Sets the tooltip markup text to be used as tooltip for the arrow button +-- which pops up the menu. See 'toolItemSetTooltip' for setting a tooltip on +-- the whole 'MenuToolButton'. +-- +-- * Available since Gtk+ version 2.12 +-- +menuToolButtonSetArrowTooltipMarkup :: MenuToolButtonClass self => self + -> Markup -- ^ @markup@ - markup text to be used as tooltip text for button's + -- arrow button + -> IO () +menuToolButtonSetArrowTooltipMarkup self markup = + withUTFString markup $ \markupPtr -> + {# call gtk_menu_tool_button_set_arrow_tooltip_markup #} + (toMenuToolButton self) + markupPtr +#endif -------------------- -- Attributes diff --git a/Graphics/UI/Gtk/Misc/Tooltip.chs b/Graphics/UI/Gtk/Misc/Tooltip.chs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Gtk/Misc/Tooltip.chs @@ -0,0 +1,220 @@ +{-# LANGUAGE CPP #-} +-- -*-haskell-*- +-- GIMP Toolkit (GTK) Widget Tooltip +-- +-- Author : Andy Stewart +-- +-- Created: 24 Mar 2010 +-- +-- Copyright (C) 2010 Andy Stewart +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- | +-- Maintainer : gtk2hs-users@lists.sourceforge.net +-- Stability : provisional +-- Portability : portable (depends on GHC) +-- +-- Add tips to your widgets +-- +-- * Module available since Gtk+ version 2.12 +-- +module Graphics.UI.Gtk.Misc.Tooltip ( + +-- * Detail +-- +-- | 'Tooltip' belongs to the new tooltips API that was introduced in Gtk+ +-- 2.12 and which deprecates the old 'Tooltips' API. +-- +-- Basic tooltips can be realized simply by using 'widgetSetTooltipText' or +-- 'widgetSetTooltipMarkup' without any explicit tooltip object. +-- +-- When you need a tooltip with a little more fancy contents, like adding an +-- image, or you want the tooltip to have different contents per 'TreeView' row +-- or cell, you will have to do a little more work: +-- +-- * Set the 'hasTooltip' property to 'True', this will make GTK+ monitor the widget for motion and +-- related events which are needed to determine when and where to show a tooltip. +-- +-- * Connect to the 'queryTooltip' signal. This signal will be emitted when a tooltip is supposed to +-- be shown. One of the arguments passed to the signal handler is a 'Tooltip' object. This is the +-- object that we are about to display as a tooltip, and can be manipulated in your callback using +-- functions like 'tooltipSetIcon'. There are functions for setting the tooltip's markup, +-- setting an image from a stock icon, or even putting in a custom widget. +-- +-- * Return 'True' from your query-tooltip handler. This causes the tooltip to be show. If you return +-- 'False', it will not be shown. +-- +-- In the probably rare case where you want to have even more control over the tooltip that is about to +-- be shown, you can set your own 'Window' which will be used as tooltip window. This works as +-- follows: +-- +-- * Set 'hasTooltip' and connect to 'queryTooltip' as before. +-- +-- * Use 'widgetSetTooltipWindow' to set a 'Window' created by you as tooltip window. +-- +-- * In the 'queryTooltip' callback you can access your window using 'widgetGetTooltipWindow' +-- and manipulate as you wish. The semantics of the return value are exactly as before, return 'True' +-- to show the window, 'False' to not show it. + +-- * Class Hierarchy +-- +-- | +-- @ +-- | 'GObject' +-- | +----Tooltip +-- @ + +#if GTK_CHECK_VERSION(2,12,0) +-- * Types + Tooltip, + TooltipClass, + castToTooltip, + toTooltip, + +-- * Methods + tooltipSetMarkup, + tooltipSetText, + tooltipSetIcon, + tooltipSetIconFromStock, +#if GTK_CHECK_VERSION(2,14,0) + tooltipSetIconFromIconName, +#endif + tooltipSetCustom, + tooltipTriggerTooltipQuery, + tooltipSetTipArea, +#endif + ) where + +import Control.Monad (liftM) +import Data.Maybe (fromMaybe) + +import System.Glib.FFI +import System.Glib.UTFString +import System.Glib.GObject (constructNewGObject,makeNewGObject) +import Graphics.UI.Gtk.General.Structs (IconSize(..), Rectangle) +import Graphics.Rendering.Pango.Markup +{#import Graphics.UI.Gtk.Types#} + +{# context lib="gtk" prefix="gtk" #} + +#if GTK_CHECK_VERSION(2,12,0) +-------------------- +-- Methods + +-- | Sets the text of the tooltip to be @markup@, which is marked up with the +-- Pango text markup language. If @markup@ is 'Nothing', the label will be hidden. +-- +tooltipSetMarkup :: TooltipClass self => self + -> Maybe Markup -- ^ @markup@ - a markup string (see Pango markup format) or 'Nothing' + -> IO () +tooltipSetMarkup self markup = + maybeWith withUTFString markup $ \markupPtr -> + {# call gtk_tooltip_set_markup #} + (toTooltip self) + markupPtr + +-- | Sets the text of the tooltip to be @text@. If @text@ is 'Nothing' +-- the label will be hidden. See also 'tooltipSetMarkup'. +-- +tooltipSetText :: TooltipClass self => self + -> Maybe String -- ^ @text@ - a text string or 'Nothing' + -> IO () +tooltipSetText self text = + maybeWith withUTFString text $ \textPtr -> + {# call gtk_tooltip_set_text #} + (toTooltip self) + textPtr + +-- | Sets the icon of the tooltip (which is in front of the text) to be +-- @pixbuf@. If @pixbuf@ is 'Nothing' the image will be hidden. +-- +tooltipSetIcon :: TooltipClass self => self + -> Maybe Pixbuf -- ^ @pixbuf@ - a 'Pixbuf' or 'Nothing' + -> IO () +tooltipSetIcon self pixbuf = + {#call tooltip_set_icon#} + (toTooltip self) + (fromMaybe (Pixbuf nullForeignPtr) pixbuf) + +-- | Sets the icon of the tooltip (which is in front of the text) to be the +-- stock item indicated by @stockId@ with the size indicated by @size@. If +-- @stockId@ is 'Nothing' the image will be hidden. +-- +tooltipSetIconFromStock :: TooltipClass self => self + -> Maybe String -- ^ @id@ a stock id, or 'Nothing' + -> IconSize -- ^ @size@ a stock icon size + -> IO () +tooltipSetIconFromStock self id size = + maybeWith withUTFString id $ \ idPtr -> + {#call tooltip_set_icon_from_stock#} + (toTooltip self) + idPtr + ((fromIntegral . fromEnum) size) + +#if GTK_CHECK_VERSION(2,14,0) +-- | Sets the icon of the tooltip (which is in front of the text) to be the +-- icon indicated by @iconName@ with the size indicated by @size@. If +-- @iconName@ is 'Nothing' the image will be hidden. +-- +-- * Available since Gtk+ version 2.14 +-- +tooltipSetIconFromIconName :: TooltipClass self => self + -> Maybe String -- ^ @iconName@ an icon name, or 'Nothing' + -> IconSize -- ^ @size@ a stock icon size + -> IO () +tooltipSetIconFromIconName self iconName size = + maybeWith withUTFString iconName $ \ iconPtr -> + {#call tooltip_set_icon_from_icon_name#} + (toTooltip self) + iconPtr + ((fromIntegral . fromEnum) size) +#endif + +-- | Replaces the widget packed into the tooltip with @customWidget@. +-- @customWidget@ does not get destroyed when the tooltip goes away. By default +-- a box with a 'Image' and 'Label' is embedded in the tooltip, which can be +-- configured using 'tooltipSetMarkup' and 'tooltipSetIcon'. +-- +tooltipSetCustom :: (TooltipClass self, WidgetClass widget) => self + -> Maybe widget -- ^ @customWidget@ a 'Widget', or 'Nothing' to unset the old custom widget. + -> IO () +tooltipSetCustom self customWidget = + {#call tooltip_set_custom#} + (toTooltip self) + (maybe (Widget nullForeignPtr) toWidget customWidget) + +-- | Triggers a new tooltip query on @display@, in order to update the current +-- visible tooltip, or to show\/hide the current tooltip. This function is +-- useful to call when, for example, the state of the widget changed by a key +-- press. +-- +tooltipTriggerTooltipQuery :: + Display -- ^ @display@ - a 'Display' + -> IO () +tooltipTriggerTooltipQuery display = + {# call gtk_tooltip_trigger_tooltip_query #} + display + +-- | Sets the area of the widget, where the contents of this tooltip apply, to +-- be @rect@ (in widget coordinates). This is especially useful for properly +-- setting tooltips on 'TreeView' rows and cells, 'IconView' +-- +-- For setting tooltips on 'TreeView', please refer to the convenience +-- functions for this: 'treeViewSetTooltipRow' and 'treeViewSetTooltipCell'. +-- +tooltipSetTipArea :: TooltipClass self => self -> Rectangle -> IO () +tooltipSetTipArea self rect = + with rect $ \ rectPtr -> + {#call tooltip_set_tip_area#} + (toTooltip self) + (castPtr rectPtr) +#endif diff --git a/Graphics/UI/Gtk/ModelView/TreeStore.hs b/Graphics/UI/Gtk/ModelView/TreeStore.hs --- a/Graphics/UI/Gtk/ModelView/TreeStore.hs +++ b/Graphics/UI/Gtk/ModelView/TreeStore.hs @@ -43,13 +43,16 @@ treeStoreLookup, treeStoreSetValue, --- treeStoreSetTree, treeStoreInsert, treeStoreInsertTree, + treeStoreInsertForest, treeStoreRemove, treeStoreClear, + + treeStoreChange, + treeStoreChangeM, ) where import Data.Bits diff --git a/Graphics/UI/Gtk/Multiline/TextBuffer.chs b/Graphics/UI/Gtk/Multiline/TextBuffer.chs --- a/Graphics/UI/Gtk/Multiline/TextBuffer.chs +++ b/Graphics/UI/Gtk/Multiline/TextBuffer.chs @@ -86,6 +86,9 @@ textBufferInsertRangeInteractive, textBufferDelete, textBufferDeleteInteractive, + textBufferSetByteString, + textBufferGetByteString, + textBufferGetByteStringSlice, textBufferSetText, textBufferGetText, textBufferGetSlice, @@ -196,6 +199,8 @@ import System.Glib.Properties import System.Glib.GObject (constructNewGObject, makeNewGObject) +import Data.ByteString (ByteString) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen, unsafePackCStringFinalizer) {#import Graphics.UI.Gtk.Types#} {#import Graphics.UI.Gtk.Signals#} {#import Graphics.UI.Gtk.Multiline.Types#} @@ -446,6 +451,61 @@ end (fromBool includeHiddenChars) >>= readUTFString + +-- | Deletes current contents of @buffer@, and inserts @text@ instead. Similar +-- to 'textBufferSetText' but uses 'ByteString' buffers. +-- +-- * The passed-in buffer must contain a valid UTF-8 encoded string. +-- +textBufferSetByteString :: TextBufferClass self => self + -> ByteString -- ^ @text@ - text to insert + -> IO () +textBufferSetByteString self text = + unsafeUseAsCStringLen text $ \(textPtr, len) -> + {# call text_buffer_set_text #} + (toTextBuffer self) + textPtr + (fromIntegral len) + +-- | Returns the text in the range [@start@,@end@). Similar to +-- `textBufferGetText` but uses 'ByteString' buffers. +-- +-- * The returned buffer is a UTF-8 encoded string. +-- +textBufferGetByteString :: TextBufferClass self => self + -> TextIter -- ^ @start@ - start of a range + -> TextIter -- ^ @end@ - end of a range + -> Bool -- ^ @includeHiddenChars@ - whether to include invisible text + -> IO ByteString +textBufferGetByteString self start end includeHiddenChars = do + sPtr <- {# call unsafe text_buffer_get_text #} + (toTextBuffer self) + start + end + (fromBool includeHiddenChars) + sLen <- lengthArray0 0 sPtr + unsafePackCStringFinalizer (castPtr sPtr) (fromIntegral sLen) + ({#call unsafe g_free#} (castPtr sPtr)) + +-- | Returns the text in the range [@start@,@end@). Similar to +-- `textBufferGetSlice` but uses 'ByteString' buffers. +-- +-- * The returned buffer is a UTF-8 encoded string. +-- +textBufferGetByteStringSlice :: TextBufferClass self => self + -> TextIter -- ^ @start@ - start of a range + -> TextIter -- ^ @end@ - end of a range + -> Bool -- ^ @includeHiddenChars@ - whether to include invisible text + -> IO ByteString +textBufferGetByteStringSlice self start end includeHiddenChars = do + sPtr <- {# call unsafe text_buffer_get_slice #} + (toTextBuffer self) + start + end + (fromBool includeHiddenChars) + sLen <- lengthArray0 0 sPtr + unsafePackCStringFinalizer (castPtr sPtr) (fromIntegral sLen) + ({#call unsafe g_free#} (castPtr sPtr)) -- | Inserts an image into the text buffer at @iter@. The image will be -- counted as one character in character counts, and when obtaining the buffer diff --git a/Graphics/UI/Gtk/Signals.chs b/Graphics/UI/Gtk/Signals.chs --- a/Graphics/UI/Gtk/Signals.chs +++ b/Graphics/UI/Gtk/Signals.chs @@ -95,6 +95,7 @@ connect_OBJECT_INT__NONE, connect_ENUM_BOOL__BOOL, connect_BOXED_INT__NONE, + connect_OBJECT_INT_INT_BOOL_OBJECT__BOOL, ) where @@ -832,4 +833,18 @@ failOnGError $ boxedPre1 (castPtr box1) >>= \box1' -> user box1' int2 + +connect_OBJECT_INT_INT_BOOL_OBJECT__BOOL :: + (GObjectClass a', GObjectClass e', GObjectClass obj) => SignalName -> + ConnectAfter -> obj -> + (a' -> Int -> Int -> Bool -> e' -> IO Bool) -> + IO (ConnectId obj) +connect_OBJECT_INT_INT_BOOL_OBJECT__BOOL signal after obj user = + connectGeneric signal after obj action + where action :: Ptr GObject -> Ptr GObject -> Int -> Int -> Bool -> Ptr GObject -> IO Bool + action _ obj1 int2 int3 bool4 obj5 = + failOnGError $ + makeNewGObject (GObject, objectUnrefFromMainloop) (return obj5) >>= \obj5' -> + makeNewGObject (GObject, objectUnrefFromMainloop) (return obj1) >>= \obj1' -> + user (unsafeCastGObject obj1') int2 int3 bool4 (unsafeCastGObject obj5') diff --git a/Graphics/UI/Gtk/Types.chs b/Graphics/UI/Gtk/Types.chs --- a/Graphics/UI/Gtk/Types.chs +++ b/Graphics/UI/Gtk/Types.chs @@ -592,6 +592,10 @@ toTreeSortable, mkTreeSortable, unTreeSortable, castToTreeSortable, gTypeTreeSortable, + Tooltip(Tooltip), TooltipClass, + toTooltip, + mkTooltip, unTooltip, + castToTooltip, gTypeTooltip, StatusIcon(StatusIcon), StatusIconClass, toStatusIcon, mkStatusIcon, unStatusIcon, @@ -1058,7 +1062,7 @@ {#pointer *GdkPixbuf as Pixbuf foreign newtype #} deriving (Eq,Ord) -mkPixbuf = (Pixbuf, objectUnrefFromMainloop) +mkPixbuf = (Pixbuf, objectUnref) unPixbuf (Pixbuf o) = o class GObjectClass o => PixbufClass o @@ -1081,7 +1085,7 @@ {#pointer *GdkPixbufAnimation as PixbufAnimation foreign newtype #} deriving (Eq,Ord) -mkPixbufAnimation = (PixbufAnimation, objectUnrefFromMainloop) +mkPixbufAnimation = (PixbufAnimation, objectUnref) unPixbufAnimation (PixbufAnimation o) = o class GObjectClass o => PixbufAnimationClass o @@ -1104,7 +1108,7 @@ {#pointer *GdkPixbufSimpleAnim as PixbufSimpleAnim foreign newtype #} deriving (Eq,Ord) -mkPixbufSimpleAnim = (PixbufSimpleAnim, objectUnrefFromMainloop) +mkPixbufSimpleAnim = (PixbufSimpleAnim, objectUnref) unPixbufSimpleAnim (PixbufSimpleAnim o) = o class PixbufAnimationClass o => PixbufSimpleAnimClass o @@ -1128,7 +1132,7 @@ {#pointer *GdkPixbufAnimationIter as PixbufAnimationIter foreign newtype #} deriving (Eq,Ord) -mkPixbufAnimationIter = (PixbufAnimationIter, objectUnrefFromMainloop) +mkPixbufAnimationIter = (PixbufAnimationIter, objectUnref) unPixbufAnimationIter (PixbufAnimationIter o) = o class GObjectClass o => PixbufAnimationIterClass o @@ -4337,6 +4341,29 @@ gTypeTreeSortable = {# call fun unsafe gtk_tree_sortable_get_type #} +-- ******************************************************************** Tooltip + +{#pointer *Tooltip foreign newtype #} deriving (Eq,Ord) + +mkTooltip = (Tooltip, objectUnrefFromMainloop) +unTooltip (Tooltip o) = o + +class GObjectClass o => TooltipClass o +toTooltip :: TooltipClass o => o -> Tooltip +toTooltip = unsafeCastGObject . toGObject + +instance TooltipClass Tooltip +instance GObjectClass Tooltip where + toGObject = GObject . castForeignPtr . unTooltip + unsafeCastGObject = Tooltip . castForeignPtr . unGObject + +castToTooltip :: GObjectClass obj => obj -> Tooltip +castToTooltip = castTo gTypeTooltip "Tooltip" + +gTypeTooltip :: GType +gTypeTooltip = + {# call fun unsafe gtk_tooltip_get_type #} + -- ***************************************************************** StatusIcon {#pointer *StatusIcon foreign newtype #} deriving (Eq,Ord) @@ -4344,12 +4371,12 @@ mkStatusIcon = (StatusIcon, objectUnrefFromMainloop) unStatusIcon (StatusIcon o) = o -class TreeSortableClass o => StatusIconClass o +class TooltipClass o => StatusIconClass o toStatusIcon :: StatusIconClass o => o -> StatusIcon toStatusIcon = unsafeCastGObject . toGObject instance StatusIconClass StatusIcon -instance TreeSortableClass StatusIcon +instance TooltipClass StatusIcon instance GObjectClass StatusIcon where toGObject = GObject . castForeignPtr . unStatusIcon unsafeCastGObject = StatusIcon . castForeignPtr . unGObject diff --git a/Graphics/UI/Gtk/Windows/Window.chs b/Graphics/UI/Gtk/Windows/Window.chs --- a/Graphics/UI/Gtk/Windows/Window.chs +++ b/Graphics/UI/Gtk/Windows/Window.chs @@ -2255,17 +2255,17 @@ -- | Observe a change in input focus. -- -setFocus :: WindowClass self => Signal self (Widget -> IO ()) -setFocus = Signal (connect_OBJECT__NONE "set-focus") +setFocus :: WindowClass self => Signal self (Maybe Widget -> IO ()) +setFocus = Signal (connect_MOBJECT__NONE "set-focus") -- * Deprecated #ifndef DISABLE_DEPRECATED -- | Observe a change in input focus. -- onSetFocus, afterSetFocus :: (WindowClass self, WidgetClass foc) => self - -> (foc -> IO ()) + -> (Maybe foc -> IO ()) -> IO (ConnectId self) -onSetFocus = connect_OBJECT__NONE "set-focus" False -afterSetFocus = connect_OBJECT__NONE "set-focus" True +onSetFocus = connect_MOBJECT__NONE "set-focus" False +afterSetFocus = connect_MOBJECT__NONE "set-focus" True #endif diff --git a/Gtk2HsSetup.hs b/Gtk2HsSetup.hs --- a/Gtk2HsSetup.hs +++ b/Gtk2HsSetup.hs @@ -455,7 +455,7 @@ -- existance of a .chs module may not depend on some CPP condition. extractDeps :: ModDep -> IO ModDep extractDeps md@ModDep { mdLocation = Nothing } = return md -extractDeps md@ModDep { mdLocation = Just f } = withFileContents f $ \con -> do +extractDeps md@ModDep { mdLocation = Just f } = withUTF8FileContents f $ \con -> do let findImports acc (('{':'#':xs):xxs) = case (dropWhile ((==) ' ') xs) of ('i':'m':'p':'o':'r':'t':' ':ys) -> case simpleParse (takeWhile ((/=) '#') ys) of diff --git a/demo/actionMenu/ActionMenu.hs b/demo/actionMenu/ActionMenu.hs new file mode 100644 --- /dev/null +++ b/demo/actionMenu/ActionMenu.hs @@ -0,0 +1,105 @@ +import Graphics.UI.Gtk + +uiDef = + "\ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \ \ + \" + +main = do + initGUI + + -- Create the menus + fileAct <- actionNew "FileAction" "File" Nothing Nothing + editAct <- actionNew "EditAction" "Edit" Nothing Nothing + + -- Create menu items + newAct <- actionNew "NewAction" "New" + (Just "Clear the spreadsheet area.") + (Just stockNew) + newAct `onActionActivate` putStrLn "New activated." + openAct <- actionNew "OpenAction" "Open" + (Just "Open an existing spreadsheet.") + (Just stockOpen) + openAct `onActionActivate` putStrLn "Open activated." + saveAct <- actionNew "SaveAction" "Save" + (Just "Save the current spreadsheet.") + (Just stockSave) + saveAct `onActionActivate` putStrLn "Save activated." + saveAsAct <- actionNew "SaveAsAction" "SaveAs" + (Just "Save spreadsheet under new name.") + (Just stockSaveAs) + saveAsAct `onActionActivate` putStrLn "SaveAs activated." + exitAct <- actionNew "ExitAction" "Exit" + (Just "Exit this application.") + (Just stockSaveAs) + exitAct `onActionActivate` mainQuit + cutAct <- actionNew "CutAction" "Cut" + (Just "Cut out the current selection.") + (Just stockCut) + cutAct `onActionActivate` putStrLn "Cut activated." + copyAct <- actionNew "CopyAction" "Copy" + (Just "Copy the current selection.") + (Just stockCopy) + copyAct `onActionActivate` putStrLn "Copy activated." + pasteAct <- actionNew "PasteAction" "Paste" + (Just "Paste the current selection.") + (Just stockPaste) + pasteAct `onActionActivate` putStrLn "Paste activated." + + standardGroup <- actionGroupNew "standard" + mapM_ (actionGroupAddAction standardGroup) [fileAct, editAct] + mapM_ (\act -> actionGroupAddActionWithAccel standardGroup act Nothing) + [newAct, openAct, saveAct, saveAsAct, exitAct, cutAct, copyAct, pasteAct] + + ui <- uiManagerNew + mid <- uiManagerAddUiFromString ui uiDef + uiManagerInsertActionGroup ui standardGroup 0 + + win <- windowNew + win `onDestroy` mainQuit + win `onSizeRequest` return (Requisition 200 100) + (Just menuBar) <- uiManagerGetWidget ui "/ui/menubar" + (Just toolBar) <- uiManagerGetWidget ui "/ui/toolbar" + + edit <- textViewNew + vBox <- vBoxNew False 0 + set vBox [boxHomogeneous := False] + boxPackStart vBox menuBar PackNatural 0 + boxPackStart vBox toolBar PackNatural 0 + boxPackStart vBox edit PackGrow 0 + + containerAdd win vBox + widgetShowAll win + + mainGUI diff --git a/demo/actionMenu/Makefile b/demo/actionMenu/Makefile new file mode 100644 --- /dev/null +++ b/demo/actionMenu/Makefile @@ -0,0 +1,11 @@ + +PROG = actionmenu +SOURCES = ActionMenu.hs + +$(PROG) : $(SOURCES) + $(HC) --make $< -o $@ $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG) + +HC=ghc diff --git a/demo/buttonbox/ButtonBox.hs b/demo/buttonbox/ButtonBox.hs new file mode 100644 --- /dev/null +++ b/demo/buttonbox/ButtonBox.hs @@ -0,0 +1,49 @@ +module Main (main) where + +import Graphics.UI.Gtk + +main :: IO () +main = do + initGUI + + -- Create a new window + window <- windowNew + + -- Here we connect the "destroy" event to a signal handler. + -- This event occurs when we call widgetDestroy on the window, + -- or if the user closes the window. + window `onDestroy` mainQuit + + -- Sets the border width of the window. + set window [ containerBorderWidth := 10 ] + + hbuttonbox <- hButtonBoxNew + + set window [ containerChild := hbuttonbox ] + + button1 <- buttonNewWithLabel "One" + button2 <- buttonNewWithLabel "Two" + button3 <- buttonNewWithLabel "Three" + + -- Add each button to the button box with the default packing and padding + set hbuttonbox [ containerChild := button + | button <- [button1, button2, button3] ] + + -- This sets button3 to be a so called 'secondary child'. When the layout + -- stlye is ButtonboxStart or ButtonboxEnd, the secondary children are + -- grouped seperately from the others. Resize the window to see the effect. + -- + -- This is not interesting in itself but shows how to set child attributes. + -- Note that the child attribute 'buttonBoxChildSecondary' takes the + -- button box container child 'button3' as a parameter. + set hbuttonbox [ buttonBoxLayoutStyle := ButtonboxStart + , buttonBoxChildSecondary button3 := True ] + + -- The final step is to display everything (the window and all the widgets + -- contained within it) + widgetShowAll window + + -- All Gtk+ applications must run the main event loop. Control ends here and + -- waits for an event to occur (like a key press or mouse event). + mainGUI + diff --git a/demo/buttonbox/Makefile b/demo/buttonbox/Makefile new file mode 100644 --- /dev/null +++ b/demo/buttonbox/Makefile @@ -0,0 +1,11 @@ + +PROG = buttonbox +SOURCES = ButtonBox.hs + +$(PROG) : $(SOURCES) + $(HC) --make $< -o $@ $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG) + +HC=ghc diff --git a/demo/carsim/CarSim.hs b/demo/carsim/CarSim.hs new file mode 100644 --- /dev/null +++ b/demo/carsim/CarSim.hs @@ -0,0 +1,284 @@ +-- program: S.A.R.A.H. jam simulator +-- author: Maurício C. Antunes +-- e-mail: mauricio.antunes@gmail.com +-- license: public domain + +module Main where +import Data.Maybe +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.EventM +import Graphics.Rendering.Cairo +import Control.Monad +import Data.IORef +import Data.List +import Data.Time +import Data.Complex + +-- Constants + +accelerator = 0.7*carSize :: Double +brake = 10*accelerator:: Double +carSize = 2*pi/59 :: Double +responseTime = 0.24 :: Double +drawSide = 5/2 :: Double + +-- A few conveniences + +eventWindowSize = do + dr <- eventWindow + (w,h) <- liftIO $ drawableGetSize dr + return $ if w*h > 1 + then (fromIntegral w, fromIntegral h) + else (1,1) + +eventPolarCoordinates = do + (w,h) <- eventWindowSize + (x,y) <- eventCoordinates + let (origX, origY) = (w/2, h/2) + let (scaleX, scaleY) = (drawSide/w, drawSide/h) + let (x',y') = (scaleX*(x-origX), scaleY*(y-origY)) + let (radius,theta) = polar $ x' :+ y' + return $ (radius,theta) + +getAndSet :: a -> IO (IO a, a -> IO ()) +getAndSet a = do + ior <- newIORef a + let get = readIORef ior + let set = writeIORef ior + return (get,set) + +diffTime :: UTCTime -> UTCTime -> Double +diffTime = (realToFrac .) . diffUTCTime + +moveToLineTo :: Double -> Double + -> Double -> Double -> Render () +moveToLineTo a b c d = moveTo a b >> lineTo c d + +-- Car list handling + +-- Each car is represented by a pair of Doubles. The first +-- Double is its position in a circular road, represented by +-- an angle. The second is its angular velocity. The general +-- idea behind the simulation is that in a list of cars each +-- one will try to keep a safe speed to avoid a crash in the +-- event of a sudden brake of the next car. + +newCarList nCars = take nCars $ zip [0,2*pi/nCars'..] (repeat 0) + where nCars' = fromIntegral nCars + +-- This resizes car lists by copying or keeping those +-- at lower speeds. + +newCarListFromList nCars [] = newCarListFromList nCars [(0,0)] +newCarListFromList nCars list = sortBy ((. fst).(compare . fst)) $ + take nCars $ cycle $ sortBy ((. snd).(compare . snd)) list + +-- Safe speed for car, given data from itself and the next +-- and, possibly, a forced (by the user) jam. Speed changes +-- are limited by accelerator and brake maxima. + +newSpeed dt jam (p1,s1) (p2,s2) = min cv $ max bv $ ds - br + where + pd = (p2-p1-carSize) - responseTime*(s2-s1) + pj = maybe pd ((subtract $ carSize/2) + . (until (>0) (+2*pi)) . (subtract p1)) jam + dd = brake*(max 0 $ min pd pj) + br = brake*responseTime + ds = sqrt $ br^2 + 2*dd + cv = s1 + accelerator*dt + bv = s1 - brake*dt + +-- Update positions and speeds based on a timestep and maybe +-- taking a forced congestion into account + +updateCarList _ _ [] = [] +updateCarList timestep jam list = zip newPositions' newSpeeds + where + fakeCar = (p+2*pi,s) where (p,s) = head list + newSpeeds = zipWith ns list (tail list ++ [fakeCar]) + where ns = newSpeed timestep jam + newPositions = zipWith3 mean fsts snds newSpeeds + where + mean a b c = a + timestep*(b+c)/2 + fsts = map fst list + snds = map snd list + newPositions' = map (subtract base) newPositions + base = (*(2*pi)) $ fromIntegral $ floor $ (/ (2*pi)) $ + head newPositions + +about = do + ad <- aboutDialogNew + aboutDialogSetName ad "S.A.R.A.H." + aboutDialogSetVersion ad "1.0" + aboutDialogSetAuthors ad $ ["Maurício C. Antunes " + ++ ""] + aboutDialogSetComments ad $ "Software Automation of " + ++ "Road Automobile Headache" + dialogRun ad + widgetDestroy ad + +main :: IO () +main = do + + initGUI + + mainWindow <- windowNew + drawingArea <- drawingAreaNew + + (getTimeStamp,setTimeStamp) <- getCurrentTime >>= getAndSet + (getCars,setCars) <- getAndSet $ newCarList 20 + (getJam,setJam) <- getAndSet Nothing + (getTimeoutId,setTimeoutId) <- getAndSet Nothing + + -- If 'resume' is called, 'step' will be called at small + -- timesteps to update car data. If 'pause' is called, 'step' + -- calls are stoped. 'resume' is called at program startup, + -- and then the pause button alternates 'resume' and 'pause'. + + let step = do + time <- getCurrentTime + dt <- getTimeStamp >>= return . (diffTime time) + setTimeStamp time + liftM2 (updateCarList dt) getJam getCars >>= setCars + let pause = do + maybe (return ()) timeoutRemove =<< getTimeoutId + setTimeoutId Nothing + let resume = do + setTimeoutId . Just =<< flip timeoutAdd 33 + (step >> widgetQueueDraw drawingArea >> return True) + getCurrentTime >>= setTimeStamp + + -- The elements of the graphic interface are the set of + -- buttons, the scale to set the number of cars and the + -- car track. They are named as 'buttons', 'howMany' and + -- 'track'. Each of them contains other widgets inside, but + -- there's no reason to expose their names to the main IO. + + buttons <- do + + qr <- buttonNewFromStock stockClear + onClicked qr $ do + (liftM length) getCars >>= setCars . newCarList + getCurrentTime >>= setTimeStamp + widgetQueueDraw drawingArea + + qp <- toggleButtonNewWithLabel stockMediaPause + buttonSetUseStock qp True + onToggled qp $ do + p <- toggleButtonGetActive qp + case p of + True -> pause + False -> resume + + qa <- buttonNewFromStock stockAbout + onClicked qa $ about + + qq <- buttonNewFromStock stockQuit + onClicked qq (do + widgetDestroy mainWindow + mainQuit) + + bb <- hButtonBoxNew + containerAdd bb qr + containerAdd bb qp + containerAdd bb qa + containerAdd bb qq + return bb + + howMany <- do + + sc <- vScaleNewWithRange 1 40 1 + afterRangeValueChanged sc $ do + v <- liftM floor $ rangeGetValue sc + c <- getCars + setCars $ newCarListFromList v c + widgetQueueDraw drawingArea + + scaleSetValuePos sc PosTop + scaleSetDigits sc 0 + rangeSetUpdatePolicy sc UpdateDiscontinuous + rangeSetValue sc =<< liftM (fromIntegral . length) getCars + + al <- alignmentNew 0.5 0.5 0 1 + alignmentSetPadding al 15 15 15 15 + containerAdd al sc + return al + + track <- do + + let dr = drawingArea + widgetAddEvents dr [PointerMotionMask] + + on dr motionNotifyEvent $ do + (r,t) <- eventPolarCoordinates + liftIO $ if (0.8> return True + + on dr exposeEvent $ do + (w,h) <- eventWindowSize + dw <- eventWindow + liftIO $ do + jam <- getJam + cars <- getCars + renderWithDrawable dw $ do + translate (w/2) (h/2) + scale (w/drawSide) (h/drawSide) + road2render jam cars + return True + + af <- aspectFrameNew 0.5 0.5 (Just 1) + frameSetShadowType af ShadowNone + containerAdd af dr + return af + + -- 'layout' is a widget that contains all interface elements + -- properly arranged. + + layout <- do + vb <- vBoxNew False 0 + hb <- hBoxNew False 0 + boxPackStart vb track PackGrow 0 + boxPackStart vb buttons PackNatural 0 + boxPackStart hb howMany PackNatural 0 + boxPackStart hb vb PackGrow 0 + return hb + + windowSetTitle mainWindow "S.A.R.A.H." + windowSetDefaultSize mainWindow 400 400 + on mainWindow objectDestroy mainQuit + containerAdd mainWindow layout + widgetShowAll mainWindow + + resume + + mainGUI + +-- As the name says, this takes road info, in the form of a +-- possible jam and a list of cars, and make it into a Cairo +-- render. Road will have radius 1. + +road2render :: Maybe Double -> [(Double,Double)] -> Render () +road2render jam cars = do + newPath + setSourceRGB 0 0 0 + drawRoad + when (isJust jam) drawJam + setSourceRGBA 0 0 0 0.55 + let cars' = map fst cars + let rotations = zipWith subtract (0:cars') cars' + sequence_ $ map ((>> drawCar) . rotate) rotations + where + drawRoad = setLineWidth 0.01 >> setDash [2*pi/34,2*pi/34] + (pi/34) >> arc 0.0 0.0 1.0 0.0 (2*pi) >> stroke + drawJam = setLineWidth 0.005 >> setDash [0.03,0.02] 0.04 >> + save >> rotate (fromJust jam) >> moveToLineTo 0.8 0 1.2 + 0 >> stroke >> setDash [] 0 >> moveToLineTo 0.8 (-0.015) + 0.8 0.015 >> moveToLineTo 1.2 (-0.015) 1.2 0.015 >> stroke + >> restore + drawCar = arc 1 0 (carSize/2) 0 (2*pi) >> fill diff --git a/demo/carsim/Makefile b/demo/carsim/Makefile new file mode 100644 --- /dev/null +++ b/demo/carsim/Makefile @@ -0,0 +1,15 @@ + +PROGS = carsim +SOURCES = CarSim.hs + +all : $(PROGS) + +carsim : CarSim.hs + $(HC_RULE) + +HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS) + +HC=ghc diff --git a/demo/concurrent/Makefile b/demo/concurrent/Makefile new file mode 100644 --- /dev/null +++ b/demo/concurrent/Makefile @@ -0,0 +1,16 @@ + +PROGS = progress progressThreadedRTS +SOURCES = Progress.hs ProgressThreadedRTS.hs + +all : $(PROGS) + +progress : Progress.hs + $(HC) --make $< -o $@ $(HCFLAGS) + +progressThreadedRTS : ProgressThreadedRTS.hs + $(HC) --make $< -o $@ -threaded $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS) + +HC=ghc diff --git a/demo/concurrent/Progress.hs b/demo/concurrent/Progress.hs new file mode 100644 --- /dev/null +++ b/demo/concurrent/Progress.hs @@ -0,0 +1,35 @@ +-- Example of concurrent Haskell and Gtk. +-- +-- As long as GHC does not support OS level threads by default, a trick has +-- to be used to let Haskell programs continue while the GUI is running. +-- We attach a call to the Haskell function "yield" to the timeout handler of +-- Gtk's main loop. Thus GHC regularly gets a chance to execute Haskell +-- threads. + +import Graphics.UI.Gtk + +import Control.Concurrent + +main :: IO () +main = do + initGUI + dia <- dialogNew + dialogAddButton dia stockClose ResponseClose + contain <- dialogGetUpper dia + pb <- progressBarNew + boxPackStartDefaults contain pb + widgetShowAll dia + forkIO (doTask pb) + + -- 50ms timeout, so GHC will get a chance to scheule about 20 times a second + -- which gives reasonable latency without the polling generating too much + -- cpu load. + timeoutAddFull (yield >> return True) priorityDefaultIdle 50 + dialogRun dia + return () + +doTask :: ProgressBar -> IO () +doTask pb = do + progressBarPulse pb + threadDelay 100000 + doTask pb diff --git a/demo/concurrent/ProgressThreadedRTS.hs b/demo/concurrent/ProgressThreadedRTS.hs new file mode 100644 --- /dev/null +++ b/demo/concurrent/ProgressThreadedRTS.hs @@ -0,0 +1,37 @@ +-- Example of concurrent Haskell and Gtk. +-- +-- This demo uses GHC's support for OS level threads. It has to be +-- linked using the ghc -threaded flag. +-- +-- Because Gtk+ is single threaded we have to be very careful to call +-- Gtk+ only from the main GUI thread. So while it's ok to forkIO, +-- any GUI actions in that thread have to be 'posted' to the main GUI +-- thread using postGUI, or postGUIAsync as in the example here. + +import Graphics.UI.Gtk + +import Control.Concurrent + +main :: IO () +main = do + + -- It is marked unsafe becuase it is your obligation to ensure you + -- only call Gtk+ from one OS thread, or 'bad things' will happen. + unsafeInitGUIForThreadedRTS + + dia <- dialogNew + dialogAddButton dia stockClose ResponseClose + contain <- dialogGetUpper dia + pb <- progressBarNew + boxPackStartDefaults contain pb + widgetShowAll dia + forkIO (doTask pb) + + dialogRun dia + return () + +doTask :: ProgressBar -> IO () +doTask pb = do + postGUIAsync $ progressBarPulse pb + threadDelay 100000 + doTask pb diff --git a/demo/demos.txt b/demo/demos.txt new file mode 100644 --- /dev/null +++ b/demo/demos.txt @@ -0,0 +1,96 @@ +Written by Paul Dufresne , january, 2008 +This is hereby released in public domain + +This describe the demos available with Gtk2HS library, an Haskell GTK+ wrapper. + +Sometimes, you may have to press Control-C to quit a program. + +actionMenu: Show you how to make a small File and a small Edit menu (also a button bar) + You will learn how to attach actions you want to do when they are activated. + +buttonBox: Build a window with three buttons, the third one, not following others when you grow the window. + +cairo: Contains some examples that use the cairo drawing library: http://cairographics.org/ + ./graph shows a mathematical curve + ./drawing shows some color lines and curves, and some 45 degree text + ./drawing2 shows some semi-transparent figures, an apple, and a snake + ./text make text.png, an image with some text in it + ./starandring make a star inside a circle, in 4 different documents: .png, .pdf, .ps, .svg + ./clock shows a very nice looking analog clock +Needs: --enable-cairo or/and cairo lib installed at build time of gtk2hs + +calc: a simple calculator + +carsim: on a ring track, up to 40 simulated cars are circulating, + you can stop the traffic by putting the mouse cursor in front of a car +Needs: --enable-cairo or/and cairo lib installed at build time of gtk2hs + +concurrent: Show how to let Haskell programs continue while the GUI is running. + +fastdraw: shows a palette of colors constantly changing (Example of a drawing graphics onto a canvas) + +filechooser: examples of Save and Open dialogs. + +fonts: shows info on all your installed fonts. + +gconf: at first execution, will show you how to enter values in gnome configuration database (much like + Windows registry), and on second execution, will monitor the values + +glade: Show how to load a simple made with Glade, and use it + +gnomevfs: Gnome virtual file system +TODO (install gnomefs and try again) + Could not find module System.Gnome.VFS + +graphics: same as ./drawing in Cairo (but without Cairo) + +gstreamer: Seems to try to play a sound file (Vorbis) +TODO (install gstreamer and try again) + Could not find module `Media.Streaming.GStreamer' + +gtkbuilder: same as ./glade, but with GtkBuilder + +hello: just a button HelloWorld that quit program (which is full of comments) + +mozembed: Probably show a web page inside a window? +TODO (install mozembed and try again) +Could not find module `Graphics.UI.Gtk.MozEmbed': + +noughty: What I call Tic-Tac-Toe game (2 human players) where one have X the other O, and +the goal of the game is to make a line of 3 yours symbols +2 versions, one without glade, and with the GUI built with Glade + +opengl: shows how to use HOpenGL inside Gtk2HS to make a rotating cube +Needs: --enable-opengl and/or mesa? installed a gtk2hs build time + +pango: use pango (http://www.pango.org/) layout to make a long paragraph adjust to wide of + the window +Needs: --enable-cairo and/or cairo lib installed at Gtk2HS build time(to render the fonts) + +profileviewer: This is a slightly larger demo that combines use of glade, the file chooser + dialog, program state (IORefs) and use of the mogul tree view wrapper interface. + The program is a simple viewer for the log files that ghc produces when you do time profiling. + +soe: SOE (School of Expression) is an alternative implementation of the graphics library used in + a book by Paul Hudak, http://www.haskell.org/soe/. +API at http://www.haskell.org/gtk2hs/docs/devel/Graphics-SOE-Gtk.html + +sourceview: a program showing itself with syntax highlighting +Needs: --enable-sourceview and/or sourceview installed at Gtk2HS build time + +statusicon: Show a door icon in Gnome (upper right), and give a message when you click on it + Use right button on it to get a menu that will allow you to quit the program +Warning: Deprecated use of `I.onPopupMenu' and `I.onActivate' + +svg: Scalable Vector Graphics, see http://www.w3.org/Graphics/SVG/About + './svgviewer imagefile.svg' to see a svg image (XML file) + './svg2png imagefile.svg imagefile.png' will create imagefile.png from imagefile.svg + (avoid thinking about doing the reverse ;-)) +Hint: if you have use starandring from cairo, 'cp ../cairo/StarAndRing.svg .' +Needs: --enable-cairo and/or cairo lib installed at Gtk2HS build time +Feature request: avoid svgviewer: user error (Pattern match failure in do expression at SvgViewer.hs:11:2-9) + when not giving any parameter + +treelist: some examples showing how to use ListView and TreeView widgets + +unicode: Example of an international dialog box (in arabic) diff --git a/demo/embedded/Embedded.hs b/demo/embedded/Embedded.hs new file mode 100644 --- /dev/null +++ b/demo/embedded/Embedded.hs @@ -0,0 +1,86 @@ +-- Use GtkSocket and GtkPlug for cross-process embedded. +-- Just startup program, press 'm' to create tab with new button. +-- Click button for hang to simulate plug hanging process, +-- but socket process still running, can switch to other tab. + +module Main where + +import System.Process +import System.Environment +import System.Directory +import System.FilePath (()) +import Control.Monad +import Control.Monad.Trans +import Control.Concurrent + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.DrawWindow +import Graphics.UI.Gtk.Gdk.EventM + +-- | Main. +main :: IO () +main = do + -- Get program arguments. + args <- getArgs + + case args of + -- Entry plug main when have two arguments. + [id] -> plugMain (toNativeWindowId $ read id :: NativeWindowId) -- get GtkSocket id + -- Othersise entry socket main when no arguments. + _ -> socketMain + +-- | GtkSocekt main. +socketMain :: IO () +socketMain = do + initGUI + + -- Create top-level window. + window <- windowNew + windowSetPosition window WinPosCenter + windowSetDefaultSize window 600 400 + windowSetTitle window "Press `m` to new tab, press `q` exit." + window `onDestroy` mainQuit + + -- Create notebook to contain GtkSocekt. + notebook <- notebookNew + window `containerAdd` notebook + + -- Handle key press. + window `on` keyPressEvent $ tryEvent $ do + keyName <- eventKeyName + liftIO $ + case keyName of + "m" -> do + -- Create new GtkSocket. + socket <- socketNew + widgetShow socket -- must show before add GtkSocekt to container + notebookAppendPage notebook socket "Tab" -- add to GtkSocekt notebook + id <- socketGetId socket -- get GtkSocket id + + -- Fork process to add GtkPlug into GtkSocekt. + path <- liftM2 () getCurrentDirectory getProgName -- get program full path + runCommand $ path ++ " " ++ (show $ fromNativeWindowId id) -- don't use `forkProcess` + return () + "q" -> mainQuit -- quit + + widgetShowAll window + + mainGUI + +-- | GtkPlug main. +plugMain :: NativeWindowId -> IO () +plugMain id = do + initGUI + + plug <- plugNew $ Just id + plug `onDestroy` mainQuit + + button <- buttonNewWithLabel "Click me to hang." + plug `containerAdd` button + + -- Simulate a plugin hanging to see if it blocks the outer process. + button `onClicked` threadDelay 5000000 + + widgetShowAll plug + + mainGUI diff --git a/demo/embedded/Makefile b/demo/embedded/Makefile new file mode 100644 --- /dev/null +++ b/demo/embedded/Makefile @@ -0,0 +1,19 @@ + +PROGS = Embedded Uzbl MPlayer +SOURCES = Embedded.hs Uzbl.hs MPlayer.hs + +all : $(PROGS) + +Embedded : Embedded.hs + $(HC) --make $< -o $@ $(HCFLAGS) + +Uzbl : Uzbl.hs + $(HC) --make $< -o $@ $(HCFLAGS) + +MPlayer : MPlayer.hs + $(HC) --make $< -o $@ $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS) + +HC=ghc diff --git a/demo/embedded/Notes.txt b/demo/embedded/Notes.txt new file mode 100644 --- /dev/null +++ b/demo/embedded/Notes.txt @@ -0,0 +1,11 @@ +If you use GtkSocket/GtkPlug with multi-processes framework. +DON'T use function `forkProcess` to spawn process! + +Because `forkProcess` just simple call C `fork`, haven't any protection, +then two processes will got *race condition*, +you will get X Window error (such as `BadWindow`) when those two processes +try to access same X resource. + +So use `runProcess` or `runCommand` instead. +Above two functions add MVar lock when spawn processes (call c_runInteractiveProcess) +to make sure two processes won't get *race condition* problem on X resource. diff --git a/demo/embedded/Uzbl.hs b/demo/embedded/Uzbl.hs new file mode 100644 --- /dev/null +++ b/demo/embedded/Uzbl.hs @@ -0,0 +1,48 @@ +-- | This is program use uzbl embedded in window to render webpage. +-- Just simple model demo for view, haven't handle event or else. +-- +-- You need install uzbl (git clone git://github.com/Dieterbe/uzbl.git) first. +-- +-- How to use: +-- ./Uzbl default open Google page. +-- ./Uzbl url will open url you input +-- +module Main where + +import Graphics.UI.Gtk +import System.Process +import System.Environment + +main :: IO () +main = do + -- Init. + initGUI + + -- Get program arguments. + args <- getArgs + let url = case args of + [arg] -> arg -- get user input url + _ -> "http://www.google.com" -- set default url + + -- Create window. + window <- windowNew + windowSetDefaultSize window 900 600 + windowSetPosition window WinPosCenter + windowSetOpacity window 0.8 -- this function need window-manager support Alpha channel in X11 + + -- Create socket. + socket <- socketNew + widgetShow socket -- must show before add to parent + window `containerAdd` socket + + -- Get socket id. + socketId <- fmap (show . fromNativeWindowId) $ socketGetId socket + + -- Start uzbl-core process. + runCommand $ "uzbl-core -s " ++ socketId ++ " -u " ++ url + + -- Show. + window `onDestroy` mainQuit + widgetShowAll window + + mainGUI diff --git a/demo/fastdraw/FastDraw.hs b/demo/fastdraw/FastDraw.hs new file mode 100644 --- /dev/null +++ b/demo/fastdraw/FastDraw.hs @@ -0,0 +1,112 @@ +{-# OPTIONS -O #-} + +-- Example of an drawing graphics onto a canvas. +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.GC + +import Data.Array.MArray +import Data.Word +import Data.IORef +import Control.Monad ( when ) +import Control.Monad.Trans ( liftIO ) +import Data.Array.Base ( unsafeWrite ) + + +main = do + initGUI + dia <- dialogNew + dialogAddButton dia stockOk ResponseOk + contain <- dialogGetUpper dia + canvas <- drawingAreaNew + canvas `on` sizeRequest $ return (Requisition 256 256) + + -- create the Pixbuf + pb <- pixbufNew ColorspaceRgb False 8 256 256 + pbData <- (pixbufGetPixels pb :: IO (PixbufData Int Word8)) + row <- pixbufGetRowstride pb + chan <- pixbufGetNChannels pb + bits <- pixbufGetBitsPerSample pb + putStrLn ("bytes per row: "++show row++", channels per pixel: "++show chan++ + ", bits per sample: "++show bits) + + -- draw into the Pixbuf + doFromTo 0 255 $ \y -> + doFromTo 0 255 $ \x -> do + writeArray pbData (x*chan+y*row) (fromIntegral x) + writeArray pbData (1+x*chan+y*row) (fromIntegral y) + writeArray pbData (2+x*chan+y*row) 0 + + -- a function to update the Pixbuf + blueRef <- newIORef 0 + dirRef <- newIORef True + let updateBlue = do + blue <- readIORef blueRef + --print blue + doFromTo 0 255 $ \y -> + doFromTo 0 255 $ \x -> + -- Here, writeArray was replaced with unsafeWrite. The latter does + -- not check that the index is within bounds which has a tremendous + -- effect on performance. + -- writeArray pbData (2+x*chan+y*row) blue -- safe checked indexing + unsafeWrite pbData (2+x*chan+y*row) blue -- unchecked indexing + + -- arrange for the canvas to be redrawn now that we've changed + -- the Pixbuf + widgetQueueDraw canvas + + -- update the blue state ready for next time + dir <- readIORef dirRef + let diff = 4 + let blue' = if dir then blue+diff else blue-diff + if dir then + if blue<=maxBound-diff then writeIORef blueRef blue' else + writeIORef blueRef maxBound >> modifyIORef dirRef not + else + if blue>=minBound+diff then writeIORef blueRef blue' else + writeIORef blueRef minBound >> modifyIORef dirRef not + return True + + idleAdd updateBlue priorityLow + canvas `on` exposeEvent $ updateCanvas pb + boxPackStartDefaults contain canvas + widgetShow canvas + dialogRun dia + return () + +updateCanvas :: Pixbuf -> EventM EExpose Bool +updateCanvas pb = do + win <- eventWindow + region <- eventRegion + liftIO $ do + gc <- gcNew win + width <- pixbufGetWidth pb + height <- pixbufGetHeight pb + pbregion <- regionRectangle (Rectangle 0 0 width height) + regionIntersect region pbregion + rects <- regionGetRectangles region +-- putStrLn ("redrawing: "++show rects) + (flip mapM_) rects $ \(Rectangle x y w h) -> do + drawPixbuf win gc pb x y x y w h RgbDitherNone 0 0 + return True + +-- GHC is much better at opimising loops like this: +-- +-- > doFromTo 0 255 $ \y -> +-- > doFromTo 0 255 $ \x -> do ... +-- +-- Than it is at optimising loops like this: +-- +-- > sequence_ [ do ... +-- > | x <- [0..255] +-- > , y <- [0..255] ] +-- +-- The first kind of loop runs significantly faster (with GHC 6.2 and 6.4) + +{-# INLINE doFromTo #-} +-- do the action for [from..to], ie it's inclusive. +doFromTo :: Int -> Int -> (Int -> IO ()) -> IO () +doFromTo from to action = + let loop n | n > to = return () + | otherwise = do action n + loop (n+1) + in loop from diff --git a/demo/fastdraw/Makefile b/demo/fastdraw/Makefile new file mode 100644 --- /dev/null +++ b/demo/fastdraw/Makefile @@ -0,0 +1,11 @@ + +PROG = fastDraw +SOURCES = FastDraw.hs + +$(PROG) : $(SOURCES) + $(HC) --make $< -o $@ $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG) + +HC=ghc diff --git a/demo/filechooser/FileChooserDemo.glade b/demo/filechooser/FileChooserDemo.glade new file mode 100644 --- /dev/null +++ b/demo/filechooser/FileChooserDemo.glade @@ -0,0 +1,416 @@ + + + + + + + 10 + True + File Chooser Demo + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + True + False + + + + True + False + 0 + + + + True + This is a demo of the GtkFileChooser that was intoduced in Gtk+ 2.4 + +The dialog has four modes: +* open file (selects existing file) +* save file (select existing or new file) +* select folder (select existing folder) +* create folder (selects existing or bew folder) + +The last demo show how you can install extra widgets or a preview widget in the file open dialog + False + False + GTK_JUSTIFY_LEFT + True + False + 0 + 0 + 10 + 10 + + + 0 + True + False + + + + + + True + GTK_BUTTONBOX_EDGE + 5 + + + + True + True + True + GTK_RELIEF_NORMAL + + + + True + 0.5 + 0.5 + 0 + 0 + + + + True + False + 2 + + + + True + gtk-open + 4 + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + True + Open File + True + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + + + + + + + True + True + True + GTK_RELIEF_NORMAL + + + + True + 0.5 + 0.5 + 0 + 0 + + + + True + False + 2 + + + + True + gtk-save-as + 4 + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + True + Save File + True + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + + + + + + + True + True + True + GTK_RELIEF_NORMAL + + + + True + 0.5 + 0.5 + 0 + 0 + + + + True + False + 2 + + + + True + gtk-open + 4 + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + True + Select Folder + True + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + + + + + + + True + True + True + GTK_RELIEF_NORMAL + + + + True + 0.5 + 0.5 + 0 + 0 + + + + True + False + 2 + + + + True + gtk-open + 4 + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + True + Create Folder + True + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + + + + + + 5 + False + True + + + + + + True + GTK_BUTTONBOX_SPREAD + 5 + + + + True + True + True + GTK_RELIEF_NORMAL + + + + True + 0.5 + 0.5 + 0 + 0 + + + + True + False + 2 + + + + True + gtk-open + 4 + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + True + Open File (with preview) + True + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + + + + + + + True + True + True + gtk-quit + True + GTK_RELIEF_NORMAL + + + + + 0 + True + True + + + + + + + diff --git a/demo/filechooser/FileChooserDemo.hs b/demo/filechooser/FileChooserDemo.hs new file mode 100644 --- /dev/null +++ b/demo/filechooser/FileChooserDemo.hs @@ -0,0 +1,169 @@ +module Main where + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Glade + +main :: IO () +main = do + initGUI + + -- load up our main window + dialogXmlM <- xmlNew "FileChooserDemo.glade" + let dialogXml = case dialogXmlM of + (Just dialogXml) -> dialogXml + Nothing -> error $ "can't find the glade file \"FileChooserDemo.glade\"" + ++ "in the current directory" + + -- get a handle on a various objects from the glade file + mainWindow <- xmlGetWidget dialogXml castToWindow "mainWindow" + mainWindow `onDestroy` mainQuit + + -- and associate actions with the buttons + selectFolderButton <- xmlGetWidget dialogXml castToButton "selectFolderButton" + selectFolderButton `onClicked` openSelectFolderDialog mainWindow + + createFolderButton <- xmlGetWidget dialogXml castToButton "createFolderButton" + createFolderButton `onClicked` openCreateFolderDialog mainWindow + + openFileButton <- xmlGetWidget dialogXml castToButton "openFileButton" + openFileButton `onClicked` openOpenFileDialog mainWindow + + saveFileButton <- xmlGetWidget dialogXml castToButton "saveFileButton" + saveFileButton `onClicked` openSaveFileDialog mainWindow + + openFilePreviewButton <- xmlGetWidget dialogXml castToButton "openFilePreviewButton" + openFilePreviewButton `onClicked` openFilePreviewDialog mainWindow + + quitButton <- xmlGetWidget dialogXml castToButton "quitButton" + quitButton `onClicked` (do + widgetDestroy mainWindow + mainQuit) + + -- The final step is to display the main window and run the main loop + widgetShowAll mainWindow + mainGUI + + +openSelectFolderDialog :: Window -> IO () +openSelectFolderDialog parentWindow = do + dialog <- fileChooserDialogNew + (Just $ "Demo of the standard dialog " + ++ "to select an existing folder") --dialog title + (Just parentWindow) --the parent window + FileChooserActionSelectFolder --the kind of dialog we want + [("Yes, this new dialog looks nice" --The buttons to display + , ResponseAccept) + ,("Eugh! Take me away!" + ,ResponseCancel)] + widgetShow dialog + response <- dialogRun dialog + case response of + ResponseAccept -> do Just fileName <- fileChooserGetFilename dialog + putStrLn $ "you selected the folder " ++ show fileName + ResponseCancel -> putStrLn "dialog canceled" + ResponseDeleteEvent -> putStrLn "dialog closed" + widgetHide dialog + +openCreateFolderDialog :: Window -> IO () +openCreateFolderDialog parentWindow = do + dialog <- fileChooserDialogNew + (Just $ "Demo of the standard dialog to select " + ++ "a new folder (or existing) folder") --dialog title + (Just parentWindow) --the parent window + FileChooserActionCreateFolder --the kind of dialog we want + [("I want this new folder" --The buttons to display + , ResponseAccept) + ,("Bored now." + ,ResponseCancel)] + widgetShow dialog + response <- dialogRun dialog + case response of + ResponseAccept -> do Just fileName <- fileChooserGetFilename dialog + putStrLn $ "you selected the folder " ++ show fileName + ResponseCancel -> putStrLn "Getting bored?" + ResponseDeleteEvent -> putStrLn "dialog closed" + widgetHide dialog + +openOpenFileDialog :: Window -> IO () +openOpenFileDialog parentWindow = do + dialog <- fileChooserDialogNew + (Just $ "Demo of the standard dialog to select " + ++ "an existing file") --dialog title + (Just parentWindow) --the parent window + FileChooserActionOpen --the kind of dialog we want + [("gtk-cancel" --The buttons to display + ,ResponseCancel) + ,("gtk-open" + , ResponseAccept)] + + widgetShow dialog + response <- dialogRun dialog + case response of + ResponseAccept -> do Just fileName <- fileChooserGetFilename dialog + putStrLn $ "you selected the file " ++ show fileName + ResponseCancel -> putStrLn "dialog canceled" + ResponseDeleteEvent -> putStrLn "dialog closed" + widgetHide dialog + +openSaveFileDialog :: Window -> IO () +openSaveFileDialog parentWindow = do + dialog <- fileChooserDialogNew + (Just $ "Demo of the standard dialog to select " + ++ "a new file") --dialog title + (Just parentWindow) --the parent window + FileChooserActionSave --the kind of dialog we want + [("gtk-cancel" --The buttons to display + ,ResponseCancel) --you can use stock buttons + ,("gtk-save" + , ResponseAccept)] + widgetShow dialog + response <- dialogRun dialog + case response of + ResponseAccept -> do Just fileName <- fileChooserGetFilename dialog + putStrLn $ "you called the new file " ++ show fileName + ResponseCancel -> putStrLn "dialog canceled" + ResponseDeleteEvent -> putStrLn "dialog closed" + widgetHide dialog + +openFilePreviewDialog :: Window -> IO () +openFilePreviewDialog parentWindow = do + dialog <- fileChooserDialogNew + (Just $ "Demo of the standard dialog to select " + ++ "a new file - with a preview widget") --dialog title + (Just parentWindow) --the parent window + FileChooserActionOpen --the kind of dialog we want + [("_Yes, yes that's very clever" --The buttons to display + , ResponseAccept) + ,("_No, I'm not impressed" + ,ResponseCancel)] + + --create and set an extra widget + checkButton <- checkButtonNewWithLabel "frobnicate this file" + dialog `fileChooserSetExtraWidget` checkButton + + --create and set a preview widget + previewLabel <- labelNew $ Just "Preview appears here" + previewLabel `labelSetLineWrap` True + dialog `fileChooserSetPreviewWidget` previewLabel + dialog `onUpdatePreview` do + previewFile <- fileChooserGetPreviewFilename dialog + previewLabel `labelSetText` case previewFile of + Nothing -> "Preview appears here" + (Just filename) -> "Just pretend this is a preview of the file:\n" ++ + show filename + + widgetShow dialog + response <- dialogRun dialog + case response of + ResponseAccept -> do fileName <- fileChooserGetFilename dialog + putStrLn $ "you selected the new file " ++ show fileName + + --check the state of the extra widget + frobnicate <- toggleButtonGetActive checkButton + putStrLn $ if frobnicate + then "you foolishly decided to frobnicate the file" + else "you wisely decided not to frobnicate the file" + ResponseCancel -> putStrLn "you were not impressed" + ResponseDeleteEvent -> putStrLn "dialog closed" + widgetHide dialog + diff --git a/demo/filechooser/Makefile b/demo/filechooser/Makefile new file mode 100644 --- /dev/null +++ b/demo/filechooser/Makefile @@ -0,0 +1,11 @@ + +PROG = filechooser +SOURCES = FileChooserDemo.hs + +$(PROG) : $(SOURCES) + $(HC) --make $< -o $@ $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG) + +HC=ghc diff --git a/demo/fonts/Fonts.hs b/demo/fonts/Fonts.hs new file mode 100644 --- /dev/null +++ b/demo/fonts/Fonts.hs @@ -0,0 +1,20 @@ +-- Example of an drawing graphics onto a canvas. +import Graphics.UI.Gtk +import Data.List ( intersperse ) + +main = do + initGUI + fm <- cairoFontMapGetDefault + ffs <- pangoFontMapListFamilies fm + mapM_ (\ff -> do + putStrLn (show ff++": ") + fcs <- pangoFontFamilyListFaces ff + mapM_ (\fc -> do + sizes <- pangoFontFaceListSizes fc + let showSize Nothing = "all sizes" + showSize (Just sz) = concat (intersperse ", " (map show sz))++ + " points" + putStrLn (" "++show fc++" in "++showSize sizes) + ) fcs + ) ffs + diff --git a/demo/fonts/Makefile b/demo/fonts/Makefile new file mode 100644 --- /dev/null +++ b/demo/fonts/Makefile @@ -0,0 +1,11 @@ + +PROG = fonts +SOURCES = Fonts.hs + +$(PROG) : $(SOURCES) + $(HC) --make $< -o $@ $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG) + +HC=ghc diff --git a/demo/graphic/Drawing.hs b/demo/graphic/Drawing.hs new file mode 100644 --- /dev/null +++ b/demo/graphic/Drawing.hs @@ -0,0 +1,46 @@ +-- Example of an drawing graphics onto a canvas. Note that this example +-- uses the old-style Gdk drawing functions. New implementations should +-- use Cairo. See examples in that directory. +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.EventM +import Graphics.UI.Gtk.Gdk.GC +import Control.Monad.Trans ( liftIO ) + +main = do + initGUI + dia <- dialogNew + dialogAddButton dia stockOk ResponseOk + contain <- dialogGetUpper dia + canvas <- drawingAreaNew + canvas `on` sizeRequest $ return (Requisition 40 40) + text <- canvas `widgetCreateLayout` "Hello World." + canvas `on` exposeEvent $ updateCanvas text + boxPackStartDefaults contain canvas + widgetShow canvas + dialogRun dia + return () + +updateCanvas :: PangoLayout -> EventM EExpose Bool +updateCanvas text = do + win <- eventWindow + liftIO $ do + (width,height) <- drawableGetSize win + gc <- gcNew win + gcSetValues gc $ newGCValues { + foreground = Color 65535 0 0, + capStyle = CapRound, + lineWidth = 20, + joinStyle = JoinRound + } + drawLines win gc [(30,30),(width-30,height-30),(width-30,30),(30,height-30)] + gcSetValues gc $ newGCValues { + foreground = Color 65535 65535 0, + lineWidth = 4 + } + drawArc win gc False 0 0 width height (135*64) (90*64) + + drawLayoutWithColors win gc 30 (height `div` 2) text + (Just (Color 0 0 0)) Nothing + + return True + diff --git a/demo/graphic/Makefile b/demo/graphic/Makefile new file mode 100644 --- /dev/null +++ b/demo/graphic/Makefile @@ -0,0 +1,11 @@ + +PROG = drawing +SOURCES = Drawing.hs + +$(PROG) : $(SOURCES) + $(HC) --make $< -o $@ $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG) + +HC=ghc diff --git a/demo/gtkbuilder/GtkBuilderTest.hs b/demo/gtkbuilder/GtkBuilderTest.hs new file mode 100644 --- /dev/null +++ b/demo/gtkbuilder/GtkBuilderTest.hs @@ -0,0 +1,22 @@ +module Main where + +import Graphics.UI.Gtk + +main = do + initGUI + + -- Create the builder, and load the UI file + builder <- builderNew + builderAddFromFile builder "simple.ui" + + -- Retrieve some objects from the UI + window <- builderGetObject builder castToWindow "window1" + button <- builderGetObject builder castToButton "button1" + + -- Basic user interation + button `onClicked` putStrLn "button pressed!" + window `onDestroy` mainQuit + + -- Display the window + widgetShowAll window + mainGUI diff --git a/demo/gtkbuilder/Makefile b/demo/gtkbuilder/Makefile new file mode 100644 --- /dev/null +++ b/demo/gtkbuilder/Makefile @@ -0,0 +1,11 @@ + +PROG = gtkbuildertest +SOURCES = GtkBuilderTest.hs + +$(PROG) : $(SOURCES) + $(HC) --make $< -o $@ $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG) + +HC=ghc diff --git a/demo/gtkbuilder/simple.ui b/demo/gtkbuilder/simple.ui new file mode 100644 --- /dev/null +++ b/demo/gtkbuilder/simple.ui @@ -0,0 +1,105 @@ + + + + + True + window1 + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + True + False + + + 6 + True + False + 0 + + + True + A simple dialog created in Glade + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + + + 0 + True + True + + + + + True + True + GTK_RELIEF_NORMAL + + + True + 0.5 + 0.5 + 0 + 0 + + + True + False + 2 + + + True + gtk-apply + 4 + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + True + Press me! + True + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + + + + 0 + True + True + + + + + + diff --git a/demo/hello/Makefile b/demo/hello/Makefile new file mode 100644 --- /dev/null +++ b/demo/hello/Makefile @@ -0,0 +1,11 @@ + +PROG = helloworld +SOURCES = World.hs + +$(PROG) : $(SOURCES) + $(HC) --make $< -o $@ $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG) + +HC=ghc diff --git a/demo/hello/World.hs b/demo/hello/World.hs new file mode 100644 --- /dev/null +++ b/demo/hello/World.hs @@ -0,0 +1,38 @@ +-- A simple program to demonstrate Gtk2Hs. +module Main (Main.main) where + +import Graphics.UI.Gtk + +main :: IO () +main = do + initGUI + -- Create a new window + window <- windowNew + -- Here we connect the "destroy" event to a signal handler. + -- This event occurs when we call widgetDestroy on the window + -- or if the user closes the window. + onDestroy window mainQuit + -- Sets the border width and tile of the window. Note that border width + -- attribute is in 'Container' from which 'Window' is derived. + set window [ containerBorderWidth := 10, windowTitle := "Hello World" ] + -- Creates a new button with the label "Hello World". + button <- buttonNew + set button [ buttonLabel := "Hello World" ] + -- When the button receives the "clicked" signal, it will call the + -- function given as the second argument. + onClicked button (putStrLn "Hello World") + -- Gtk+ allows several callbacks for the same event. + -- This one will cause the window to be destroyed by calling + -- widgetDestroy. The callbacks are called in the sequence they were added. + onClicked button $ do + putStrLn "A \"clicked\"-handler to say \"destroy\"" + widgetDestroy window + -- Insert the hello-world button into the window. + set window [ containerChild := button ] + -- The final step is to display this newly created widget. Note that this + -- also allocates the right amount of space to the windows and the button. + widgetShowAll window + -- All Gtk+ applications must have a main loop. Control ends here + -- and waits for an event to occur (like a key press or mouse event). + -- This function returns if the program should finish. + mainGUI diff --git a/demo/inputmethod/Layout.hs b/demo/inputmethod/Layout.hs new file mode 100644 --- /dev/null +++ b/demo/inputmethod/Layout.hs @@ -0,0 +1,159 @@ +-- Example of using a PangoLayout + +import Data.IORef + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.EventM +import Graphics.Rendering.Cairo + +loremIpsum = "Lorem ipsum dolor sit amet, consectetur adipisicing elit,\ + \ sed do eiusmod tempor incididunt ut labore et dolore magna\ + \ aliqua. Ut enim ad minim veniam, quis nostrud exercitation\ + \ ullamco laboris nisi ut aliquip ex ea commodo consequat.\ + \ Duis aute irure dolor in reprehenderit in voluptate\ + \ velit esse cillum dolore eu fugiat nulla pariatur.\ + \ Excepteur sint occaecat cupidatat non proident, sunt in culpa\ + \ qui officia deserunt mollit anim id est laborum." + +data Buffer = Buffer String Int + +defaultBuffer = Buffer loremIpsum (length loremIpsum) + +displayBuffer (Buffer str pos) = + before ++ "" ++ after + where (before,after) = splitAt pos str + +displayBufferPreedit (Buffer str pos) preeditStr preeditPos = + before ++ "[" ++ prebefore ++ "" ++ preafter ++ "]" ++ after + where (before,after) = splitAt pos str + (prebefore, preafter) = splitAt preeditPos preeditStr + +insertStr new (Buffer str pos) = Buffer (before++new++after) (pos+length new) + where (before,after) = splitAt pos str + +deleteChar b@(Buffer str 0) = b +deleteChar (Buffer str pos) = Buffer (init before ++ after) (pos-1) + where (before,after) = splitAt pos str + +moveLeft b@(Buffer str pos) | pos==0 = b + | otherwise = Buffer str (pos-1) + +moveRight b@(Buffer str pos) | pos==length str = b + | otherwise = Buffer str (pos+1) + +main = do + initGUI + + -- Create the main window. + win <- windowNew + on win objectDestroy mainQuit + -- Create a drawing area in which we can render text. + area <- drawingAreaNew + containerAdd win area + on area sizeRequest $ return (Requisition 100 100) + + -- Our widget's data + buffer <- newIORef defaultBuffer + + preeditRef <- newIORef Nothing + + -- Create a Cairo Context that contains information about the current font, + -- etc. + ctxt <- cairoCreateContext Nothing + lay <- layoutEmpty ctxt + layoutSetWrap lay WrapWholeWords + + let relayout = do + buffer@(Buffer _ cursor) <- readIORef buffer + preedit <- readIORef preeditRef + case preedit of + Nothing -> do + layoutSetText lay (displayBuffer buffer) + layoutSetAttributes lay [] + Just (str,attrs,pos) -> do + layoutSetText lay (displayBufferPreedit buffer str pos) + layoutSetAttributes lay (map (shiftAttribute (cursor + 1)) + (concat attrs)) + widgetQueueDraw area + + relayout + + -- Wrap the layout to a different width each time the window is resized. + on area sizeAllocate $ \(Rectangle _ _ w _) -> + layoutSetWidth lay (Just (fromIntegral w)) + + -- Setup the handler to draw the layout. + on area exposeEvent $ updateArea area lay + + -- Set up input method + im <- imMulticontextNew + + on im imContextPreeditStart $ do + writeIORef preeditRef (Just ("",[],0)) + relayout + on im imContextPreeditEnd $ do + writeIORef preeditRef Nothing + relayout + on im imContextPreeditChanged $ do + writeIORef preeditRef . Just =<< imContextGetPreeditString im + relayout + on im imContextCommit $ \str -> do + modifyIORef buffer (insertStr str) + relayout + on im imContextRetrieveSurrounding $ do + Buffer text pos <- readIORef buffer + imContextSetSurrounding im text pos + return True + on im imContextDeleteSurrounding' $ \off nchars -> do + putStrLn $ "delete-surrounding("++show off++","++show nchars++")" + return False + + on win realize $ do + imContextSetClientWindow im . Just =<< widgetGetDrawWindow win + on win focusInEvent $ liftIO (imContextFocusIn im) >> return False + on win focusOutEvent $ liftIO (imContextFocusOut im) >> return False + on win keyReleaseEvent $ imContextFilterKeypress im + on win keyPressEvent $ do + imHandled <- imContextFilterKeypress im + if imHandled then return True else do + mod <- interpretKeyPress + case mod of + Just f -> liftIO $ modifyIORef buffer f >> relayout >> return True + Nothing -> return False + + widgetShowAll win + mainGUI + +updateArea :: DrawingArea -> PangoLayout -> EventM EExpose Bool +updateArea area lay = do + win <- eventWindow + liftIO $ do + renderWithDrawable win $ do + moveTo 0 0 + showLayout lay + + return True + +interpretKeyPress :: EventM EKey (Maybe (Buffer -> Buffer)) +interpretKeyPress = do + modifiers <- eventModifier + if modifiers /= [] then return Nothing else do + keyName <- eventKeyName + keyChar <- fmap keyToChar eventKeyVal + case keyChar of + Just ch -> do + -- This does not appear to get called; the IM handles + -- unmodified keypresses. + liftIO $ putStrLn "Literal character not handled by IM" + returnJust (insertStr [ch]) + Nothing -> do + case keyName of + "Left" -> returnJust moveLeft + "Right" -> returnJust moveRight + "BackSpace" -> returnJust deleteChar + _ -> return Nothing + where returnJust = return . Just + +shiftAttribute :: Int -> PangoAttribute -> PangoAttribute +shiftAttribute x attr = attr { paStart = x + paStart attr, + paEnd = x + paEnd attr } diff --git a/demo/inputmethod/Makefile b/demo/inputmethod/Makefile new file mode 100644 --- /dev/null +++ b/demo/inputmethod/Makefile @@ -0,0 +1,11 @@ + +PROG = layout +SOURCES = Layout.hs + +$(PROG) : $(SOURCES) + $(HC) --make $< -o $@ $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG) + +HC=ghc diff --git a/demo/menu/ComboDemo.hs b/demo/menu/ComboDemo.hs new file mode 100644 --- /dev/null +++ b/demo/menu/ComboDemo.hs @@ -0,0 +1,43 @@ +module Main where + +import Graphics.UI.Gtk +import Control.Concurrent.MVar +import Control.Monad ( liftM ) +import Data.Maybe ( fromMaybe ) +import Data.List ( findIndex ) + + +main = do + initGUI + + win <- windowNew + onDestroy win mainQuit + + combo <- comboBoxEntryNewText + mapM_ (comboBoxAppendText combo) + (words "ice-cream turkey pasta sandwich steak") + + -- select the first item + comboBoxSetActive combo 0 + + -- Get the entry widget that the ComboBoxEntry uses. + (Just w) <- binGetChild combo + let entry = castToEntry w + + -- Whenever the user has completed editing the text, append the new + -- text to the store unless it's already in there. + onEntryActivate entry $ do + str <- entryGetText entry + store <- comboBoxGetModelText combo + elems <- listStoreToList store + comboBoxSetActive combo (-1) + idx <- case (findIndex ((==) str) elems) of + Just idx -> return idx + Nothing -> listStoreAppend store str + comboBoxSetActive combo idx + return () + + containerAdd win combo + + widgetShowAll win + mainGUI diff --git a/demo/menu/Makefile b/demo/menu/Makefile new file mode 100644 --- /dev/null +++ b/demo/menu/Makefile @@ -0,0 +1,18 @@ + +PROGS = menudemo combodemo +SOURCES = MenuDemo.hs ComboDemo.hs + +all : $(PROGS) + +menudemo : MenuDemo.hs + $(HC_RULE) + +combodemo : ComboDemo.hs + $(HC_RULE) + +HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG) + +HC=ghc diff --git a/demo/menu/MenuDemo.hs b/demo/menu/MenuDemo.hs new file mode 100644 --- /dev/null +++ b/demo/menu/MenuDemo.hs @@ -0,0 +1,70 @@ +module Main (main) where + +import Graphics.UI.Gtk + +{- + widgets that go into making a menubar and submenus: + * menu item (what the user wants to select) + * menu (acts as a container for the menu items) + * menubar (container for each of the individual menus) + menuitem widgets are used for two different things: + * they are packed into the menu + * they are packed into the menubar, which, when selected, activates the menu + Functions: + * menuBarNew + creates a new menubar, which can be packed into a container like a + window or a box + * menuNew + creates a new menu, which is never actually shown; it is just a + container for the menu items + * menuItemNew, menuItemNewWithLabel, menuItemMenuWithMnemonic + create the menu items that are to be displayed; they are actually + buttons with associated actions + Once a menu item has been created, it should be put into a menu with + the menuShellAppend function. + In order to capture when the item is selected by the user, the + activate signal need to be connected in the usual way. +-} + +createMenuBar descr + = do bar <- menuBarNew + mapM_ (createMenu bar) descr + return bar + where + createMenu bar (name,items) + = do menu <- menuNew + item <- menuItemNewWithLabelOrMnemonic name + menuItemSetSubmenu item menu + menuShellAppend bar item + mapM_ (createMenuItem menu) items + createMenuItem menu (name,action) + = do item <- menuItemNewWithLabelOrMnemonic name + menuShellAppend menu item + case action of + Just act -> onActivateLeaf item act + Nothing -> onActivateLeaf item (return ()) + menuItemNewWithLabelOrMnemonic name + | elem '_' name = menuItemNewWithMnemonic name + | otherwise = menuItemNewWithLabel name + +menuBarDescr + = [ ("_File", [ ("Open", Nothing) + , ("Save", Nothing) + , ("_Quit", Just mainQuit) + ] + ) + , ("Help", [ ("_Help", Nothing) + ] + ) + ] + +main = + do initGUI + window <- windowNew + menuBar <- createMenuBar menuBarDescr + set window [ windowTitle := "Demo" + , containerChild := menuBar + ] + onDestroy window mainQuit + widgetShowAll window + mainGUI diff --git a/demo/statusicon/Makefile b/demo/statusicon/Makefile new file mode 100644 --- /dev/null +++ b/demo/statusicon/Makefile @@ -0,0 +1,11 @@ + +PROG = statusIcon +SOURCES = StatusIcon.hs + +$(PROG) : $(SOURCES) + $(HC) --make $< -o $@ $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG) + +HC=ghc diff --git a/demo/statusicon/StatusIcon.hs b/demo/statusicon/StatusIcon.hs new file mode 100644 --- /dev/null +++ b/demo/statusicon/StatusIcon.hs @@ -0,0 +1,30 @@ +-- Simple StatusIcon example +import Graphics.UI.Gtk +import qualified Graphics.UI.Gtk.Display.StatusIcon as I + + +main = do + initGUI + icon <- statusIconNewFromStock stockQuit + statusIconSetVisible icon True + statusIconSetTooltip icon "This is a test" + menu <- mkmenu icon + I.onPopupMenu icon $ \b a -> do + widgetShowAll menu + print (b,a) + menuPopup menu $ maybe Nothing (\b' -> Just (b',a)) b + I.onActivate icon $ do + putStrLn "'activate' signal triggered" + mainGUI + +mkmenu s = do + m <- menuNew + mapM_ (mkitem m) [("Let's blink!",statusIconSetBlinking s True) + ,("Let's stop blink!",statusIconSetBlinking s False) + ,("Quit",mainQuit)] + return m + where + mkitem menu (label,act) = + do i <- menuItemNewWithLabel label + menuShellAppend menu i + i `onActivateLeaf` act diff --git a/demo/treeList/Completion.hs b/demo/treeList/Completion.hs new file mode 100644 --- /dev/null +++ b/demo/treeList/Completion.hs @@ -0,0 +1,82 @@ +-- Demo to show off entry completion. + +import Graphics.UI.Gtk +import Data.Char +import Data.List + +data ColorDesc = ColorDesc { + cdColor :: Color, + cdName :: String + } deriving Show + +compareCol :: ColumnId ColorDesc String +compareCol = makeColumnIdString 0 + +invertColor (Color r g b) = Color (32767+r) (32767+g) (32767+b) +--Color (65535-r) (65535-g) (65535-b) + +parseColor s = ColorDesc c (dropWhile isSpace (upperToSpace name)) + where + s1 = dropWhile isSpace s + (s2,s3) = span isDigit s1 + s4 = dropWhile isSpace s3 + (s5,s6) = span isDigit s4 + s7 = dropWhile isSpace s6 + (s8,s9) = span isDigit s7 + n1 = read ('0':s2) + n2 = read ('0':s5) + n3 = read ('0':s8) + c = Color (n1*256+n1) (n2*256+n2) (n3*256+n3) + name = dropWhile isSpace s9 + upperToSpace [] = [] + upperToSpace (x:xs) | isUpper x = ' ':toLower x:upperToSpace xs + | otherwise = x:upperToSpace xs + +main = + do + initGUI + window <- windowNew + + contents <- readFile "rgb.txt" + let killDups [] = [] + killDups [x] = [x] + killDups (x:y:xs) | cdName x==cdName y = killDups (y:xs) + | otherwise = x:killDups (y:xs) + cols = killDups $ map parseColor (drop 1 (lines contents)) + store <- listStoreNew cols + customStoreSetColumn store compareCol cdName + + entry <- entryNew + completion <- entryCompletionNew + entrySetCompletion entry completion + + set completion [entryCompletionModel := Just store] + cell <- cellRendererTextNew + set cell [cellTextBackgroundSet := True, + cellTextForegroundSet := True] + cellLayoutPackStart completion cell True + cellLayoutSetAttributes completion cell store + (\cd -> [cellText := cdName cd, + cellTextBackgroundColor := cdColor cd, + cellTextForegroundColor := invertColor (cdColor cd)]) + entryCompletionSetMatchFunc completion (matchFunc store) + on completion matchSelected $ \model iter -> do + color <- treeModelGetValue model iter compareCol + entrySetText entry color + return True + set window [containerChild := entry] + widgetShowAll window + onDestroy window mainQuit + mainGUI + +matchFunc :: ListStore ColorDesc -> String -> TreeIter -> IO Bool +matchFunc model str iter = do + --putStrLn ("iter is "++show iter) + tp <- treeModelGetPath model iter + r <- case tp of + (i:_) -> do row <- listStoreGetValue model i + return $ any (isPrefixOf (map toLower str)) + (words (map toLower (cdName row))) + otherwise -> return False + return r + diff --git a/demo/treeList/DirList.hs b/demo/treeList/DirList.hs new file mode 100644 --- /dev/null +++ b/demo/treeList/DirList.hs @@ -0,0 +1,82 @@ +{-# OPTIONS -cpp #-} +-- Test file for the ListView widget. +module Main(main) where + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.ModelView as New + +import Control.Exception +import System.Directory +import System.IO +import System.Locale +import System.Time + +data FileInfo = FileInfo { + fName :: String, + fSize :: Integer, + fTime :: ClockTime +} + +main = do + initGUI + win <- windowNew + win `onDestroy` mainQuit + + curDir <- getCurrentDirectory + files <- getDirectoryContents curDir + fInfos <- (flip mapM) files $ \f -> do + s <- handle (\e -> +#if __GLASGOW_HASKELL__>=610 + case e :: SomeException of + e -> +#endif + return 0) $ do + h <- openFile f ReadMode + s <- hFileSize h + hClose h + return s + t <- getModificationTime f + return FileInfo { fName = f + , fSize = s + , fTime = t } + + store <- New.listStoreNew fInfos + + tv <- New.treeViewNewWithModel store + containerAdd win tv + + tvc <- New.treeViewColumnNew + set tvc [ New.treeViewColumnTitle := "File name" + , New.treeViewColumnResizable := True ] + New.treeViewAppendColumn tv tvc + + name <- New.cellRendererTextNew + New.treeViewColumnPackStart tvc name True + New.cellLayoutSetAttributes tvc name store $ \FileInfo { fName = name } -> + [ New.cellText := name ] + + tvc <- New.treeViewColumnNew + set tvc [ New.treeViewColumnTitle := "Size" + , New.treeViewColumnResizable := True ] + New.treeViewAppendColumn tv tvc + + size <- New.cellRendererTextNew + New.treeViewColumnPackStart tvc size True + New.cellLayoutSetAttributes tvc size store $ \FileInfo { fSize = size } -> + [ New.cellText := show size ] + + tvc <- New.treeViewColumnNew + set tvc [ New.treeViewColumnTitle := "Modification time" + , New.treeViewColumnResizable := True ] + New.treeViewAppendColumn tv tvc + + time <- New.cellRendererTextNew + New.treeViewColumnPackStart tvc time True + New.cellLayoutSetAttributes tvc time store $ \FileInfo { fTime = time } -> + [ New.cellText :=> do + calTime <- toCalendarTime time + return (formatCalendarTime defaultTimeLocale "%D %T" calTime) + ] + + widgetShowAll win + mainGUI diff --git a/demo/treeList/FilterDemo.hs b/demo/treeList/FilterDemo.hs new file mode 100644 --- /dev/null +++ b/demo/treeList/FilterDemo.hs @@ -0,0 +1,71 @@ +-- a demo that shows how to create a normal tree view and a tree view in +-- which only a chosen subset of rows are shown (namely those with upper case letters) +module Main ( main ) where + +import Graphics.UI.Gtk +import Data.List +import Data.Char +import Debug.Trace + +-- | Define a virtual column of the model that determines the visibility of a row in +-- the model. +visCol :: ColumnId String Bool +visCol = makeColumnIdBool 0 + +main = do + initGUI + + win <- windowNew + onDestroy win mainQuit + + content <- readFile "FilterDemo.hs" + + -- create a view that shows all lines + model <- listStoreNew (lines content) + viewAll <- treeViewNewWithModel model + col <- treeViewColumnNew + ren <- cellRendererTextNew + cellLayoutPackStart col ren True + cellLayoutSetAttributes col ren model $ \row -> [ cellText := row ] + treeViewAppendColumn viewAll col + + -- create a view that only shows lines with upper case characters + fModel <- treeModelFilterNew model [] + + -- create a virtual column 'visCol' that contains @True@ if a certain row has + -- upper case letters. Then set this column to determine the visibility of a row. + customStoreSetColumn model visCol (any isUpper) + treeModelFilterSetVisibleColumn fModel visCol + +{- + -- this is an alternative way to determine the visibility of a row. In this case, + -- it is not necessary to create the column 'visCol'. + treeModelFilterSetVisibleFunc fModel $ Just $ \iter -> do + row <- treeModelGetRow model iter + return (any isUpper row) +-} + -- note: it is important to insert the model into the view after the visibility + -- row or the visibility function have been set. Otherwise, the view is filled + -- first and setting a new visibility column/function will not update the view. + viewFew <- treeViewNewWithModel fModel + col <- treeViewColumnNew + ren <- cellRendererTextNew + cellLayoutPackStart col ren True + cellLayoutSetAttributes col ren model $ \row -> [ cellText := row ] + + treeViewAppendColumn viewFew col + + + + box <- vBoxNew False 0 + swAll <- scrolledWindowNew Nothing Nothing + containerAdd swAll viewAll + boxPackStart box swAll PackGrow 4 + + swFew <- scrolledWindowNew Nothing Nothing + containerAdd swFew viewFew + boxPackEnd box swFew PackGrow 4 + + containerAdd win box + widgetShowAll win + mainGUI diff --git a/demo/treeList/ListDND.hs b/demo/treeList/ListDND.hs new file mode 100644 --- /dev/null +++ b/demo/treeList/ListDND.hs @@ -0,0 +1,248 @@ +module Main where + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.EventM + +import System.Glib.GObject ( toGObject ) +import System.FilePath +import Control.Concurrent.MVar +import Control.Monad ( liftM ) +import Control.Monad.Trans ( liftIO ) +import Data.Maybe ( fromMaybe ) +import Data.List ( findIndex ) + +roomStrCol :: ColumnId String String +roomStrCol = makeColumnIdString 1 + +-- Define a string column and an image column on the store holding the +-- computer types. +compPicCol :: ColumnId CompType Pixbuf +compPicCol = makeColumnIdPixbuf 1 + +compStrCol :: ColumnId CompType String +compStrCol = makeColumnIdString 2 + +data Computer = Computer { + name :: String, + addr :: (Int, Int, Int, Int), + roomStore :: ListStore String, + roomSel :: Int, + cType :: CompType } + +data CompType + = MacBookPro + | MacBook + | Printer + | MacPro + | Xserve + | IMac + deriving (Enum, Bounded, Show) + +showCT :: CompType -> String +showCT ct = case show ct of + 'I':xs -> 'i':xs + xs -> xs + +main = do + initGUI + + win <- windowNew + onDestroy win mainQuit + + -- create a tag that we use as selection, target and selection type + compTypeTag <- atomNew "_CompType" + + let pNames = map ("resListDND" ) + ["laptop.png","laptopSmall.png","printer.png", + "tower.png","server.png","desktop.png"] + pics <- mapM pixbufNewFromFile pNames + + smallPics <- mapM (\n -> pixbufNewFromFileAtScale n 48 48 True) pNames + + [noRoom, publicRoom, restrictedRoom] <- mapM listStoreNew + [["Paul (Home)","John (Home)","Fred (Home)"], + ["N12","S112", "S113", "S114"], + ["Server Room Upstairs", "Server Room Downstairs"]] + + -- define extractor function for the string column + treeModelSetColumn noRoom roomStrCol id + treeModelSetColumn publicRoom roomStrCol id + treeModelSetColumn restrictedRoom roomStrCol id + + let genRoomStore MacBookPro = noRoom + genRoomStore MacBook = noRoom + genRoomStore Printer = publicRoom + genRoomStore MacPro = publicRoom + genRoomStore Xserve = restrictedRoom + genRoomStore IMac = publicRoom + + -- the initial computer list - it's a coincidence that there's + -- one computer of each type + content <- listStoreNewDND + (map (\t -> Computer { name = showCT t, addr = (192,168,0,fromEnum t+1), + roomStore = genRoomStore t, roomSel = 0, cType = t}) + [minBound :: CompType .. maxBound]) + (Just listStoreDefaultDragSourceIface) + (Just DragDestIface { + treeDragDestRowDropPossible = \store path@(i:_) -> do + mCT <- selectionDataGet compTypeTag + case mCT :: Maybe [Int] of + Just [ct] -> return True + Nothing -> + (treeDragDestRowDropPossible listStoreDefaultDragDestIface) + store path + _ -> return False, + treeDragDestDragDataReceived = \store path@(i:_) -> do + mCT <- selectionDataGet compTypeTag + case mCT of + Just [ct] -> do + let t = toEnum ct + liftIO $ listStoreInsert store i + Computer { name = showCT t, addr = (192,168,0,254), + roomStore = genRoomStore t, roomSel = 0, + cType = t } + return True + Nothing -> + (treeDragDestDragDataReceived listStoreDefaultDragDestIface) + store path + }) + -- the area with the possible computer types + compTypes <- listStoreNewDND [minBound :: CompType .. maxBound] + (Just DragSourceIface { + treeDragSourceRowDraggable = \store (i:_) -> return True, + treeDragSourceDragDataGet = \store (i:_) -> do + ty <- selectionDataGetTarget + ct <- liftIO $ listStoreGetValue store i + selectionDataSet compTypeTag [fromEnum ct] + return True, + treeDragSourceDragDataDelete = \store path -> return True + }) + Nothing + + -- define extractor functions for the two column + treeModelSetColumn compTypes compPicCol $ + \t -> pics !! fromEnum t + treeModelSetColumn compTypes compStrCol showCT + + -- create an icon view of all the computer types + typesView <- iconViewNew + set typesView [iconViewModel := Just compTypes, + iconViewPixbufColumn := compPicCol, + iconViewTextColumn := compStrCol, + iconViewColumns := 6] + + -- create an editable list of computers + inventory <- treeViewNewWithModel content + + tyCol <- treeViewColumnNew + treeViewColumnSetTitle tyCol "Type" + picRen <- cellRendererPixbufNew + treeViewColumnPackStart tyCol picRen False + cellLayoutSetAttributes tyCol picRen content + (\Computer { cType = t} -> [cellPixbuf := smallPics !! fromEnum t]) + tyRen <- cellRendererTextNew + treeViewColumnPackStart tyCol tyRen False + cellLayoutSetAttributes tyCol tyRen content + (\Computer { cType = t} -> [cellText := showCT t]) + treeViewAppendColumn inventory tyCol + + nameCol <- treeViewColumnNew + treeViewColumnSetTitle nameCol "Name" + treeViewColumnSetResizable nameCol True + treeViewColumnSetMinWidth nameCol 100 + nameRen <- cellRendererTextNew + set nameRen [ cellTextEditable := True, + cellTextEditableSet := True, + cellTextEllipsize := EllipsizeEnd, + cellTextEllipsizeSet := True] + treeViewColumnPackStart nameCol nameRen True + cellLayoutSetAttributes nameCol nameRen content + (\Computer { name = n } -> [cellText := n]) + treeViewAppendColumn inventory nameCol + on nameRen edited $ \[i] str -> do + val <- listStoreGetValue content i + listStoreSetValue content i val { name = str } + + addrCol <- treeViewColumnNew + treeViewColumnSetTitle addrCol "Address" + oct1 <- cellRendererTextNew + dot1 <- cellRendererTextNew + oct2 <- cellRendererTextNew + dot2 <- cellRendererTextNew + oct3 <- cellRendererTextNew + dot3 <- cellRendererTextNew + oct4 <- cellRendererTextNew + mapM_ (uncurry (cellLayoutPackStart addrCol)) + [(oct1, True), (dot1, False), (oct2, True), + (dot2, False), (oct3, True), (dot3, False), (oct4, True)] + mapM_ (\d -> set d [cellText := ".", + cellTextWidthChars := 0]) [dot1, dot2, dot3] + mapM_ (\o -> set o [cellXAlign := 1.0, + cellTextWidthChars := 3]) [oct1, oct2, oct3, oct4] + cellLayoutSetAttributes addrCol oct1 content + (\Computer { addr = (o1,_,_,_)} -> [cellText := show o1]) + cellLayoutSetAttributes addrCol oct2 content + (\Computer { addr = (_,o2,_,_)} -> [cellText := show o2]) + cellLayoutSetAttributes addrCol oct3 content + (\Computer { addr = (_,_,o3,_)} -> [cellText := show o3]) + cellLayoutSetAttributes addrCol oct4 content + (\Computer { addr = (_,_,_,o4)} -> [cellText := show o4]) + treeViewAppendColumn inventory addrCol + + roomCol <- treeViewColumnNew + treeViewColumnSetTitle roomCol "Room" + treeViewColumnSetResizable roomCol True + treeViewColumnSetSizing roomCol TreeViewColumnAutosize + roomRen <- cellRendererComboNew + set roomRen [ cellTextEditable := True, + cellTextEditableSet := True, + cellComboHasEntry := True ] + treeViewColumnPackStart roomCol roomRen True + cellLayoutSetAttributes roomCol roomRen content + (\Computer { roomStore = t, roomSel = idx } -> + [cellText :=> listStoreGetValue t idx, + cellComboTextModel := (t, roomStrCol)]) + on roomRen edited $ \[i] str -> do + row@Computer { roomStore = t } <- listStoreGetValue content i + elems <- listStoreToList t + idx <- case (findIndex ((==) str) elems) of + Just idx -> return idx + Nothing -> listStoreAppend t str + listStoreSetValue content i row { roomSel = idx } + treeViewAppendColumn inventory roomCol + + -- make typesView a drag source for compTypeTag values + tl <- targetListNew + targetListAdd tl compTypeTag [TargetSameApp] 0 + iconViewEnableModelDragSource typesView [Button1] tl [ActionCopy] + + -- Due to a bug in Gtk+, the treeDragSourceDragDataGet handler in + -- the DND source handler is not called unless the IconView is also + -- set to be a DND destination. Bugzilla 550528 + tl <- targetListNew + iconViewEnableModelDragDest typesView tl [] + + -- make the inventory widget a drag destination for compTypeTag values + tl <- targetListNew + targetListAdd tl compTypeTag [TargetSameApp] 0 + targetListAdd tl targetTreeModelRow [TargetSameWidget] 0 + treeViewEnableModelDragDest inventory tl [ActionMove] + tl <- targetListNew + targetListAdd tl targetTreeModelRow [TargetSameWidget] 0 + treeViewEnableModelDragSource inventory [Button1] tl [ActionMove] + + -- Install drag and drop for permuting rows. This is now done above using + -- the explicit target 'targetTreeModelRow'. Calling the function below + -- will set a completely new 'TargetList' thereby removing our own + -- 'compTypeTag' from the inventory widget's target list. + + --treeViewSetReorderable inventory True + + -- arrange the widgets + v <- vPanedNew + panedAdd1 v typesView + panedAdd2 v inventory + containerAdd win v + + widgetShowAll win + mainGUI diff --git a/demo/treeList/ListDemo.hs b/demo/treeList/ListDemo.hs new file mode 100644 --- /dev/null +++ b/demo/treeList/ListDemo.hs @@ -0,0 +1,66 @@ +module Main where + +import Graphics.UI.Gtk +import System.Glib.Signals (on) +import Data.List ( isPrefixOf ) +import Data.Char ( toLower ) + +data Phone = Phone { name :: String, number :: Int, marked :: Bool } + +main = do + initGUI + + win <- windowNew + onDestroy win mainQuit + + -- create a new list model + model <- listStoreNew + [Phone { name = "Foo", number = 12345, marked = False } + ,Phone { name = "Bar", number = 67890, marked = True } + ,Phone { name = "Baz", number = 39496, marked = False }] + view <- treeViewNewWithModel model + + treeViewSetHeadersVisible view True + + -- add a couple columns + col1 <- treeViewColumnNew + col2 <- treeViewColumnNew + col3 <- treeViewColumnNew + + treeViewColumnSetTitle col1 "String column" + treeViewColumnSetTitle col2 "Int column" + treeViewColumnSetTitle col3 "Bool column" + + renderer1 <- cellRendererTextNew + renderer2 <- cellRendererTextNew + renderer3 <- cellRendererToggleNew + + cellLayoutPackStart col1 renderer1 True + cellLayoutPackStart col2 renderer2 True + cellLayoutPackStart col3 renderer3 True + + cellLayoutSetAttributes col1 renderer1 model $ \row -> [ cellText := name row ] + cellLayoutSetAttributes col2 renderer2 model $ \row -> [ cellText := show (number row) ] + cellLayoutSetAttributes col3 renderer3 model $ \row -> [ cellToggleActive := marked row ] + + treeViewAppendColumn view col1 + treeViewAppendColumn view col2 + treeViewAppendColumn view col3 + + -- update the model when the toggle buttons are activated + on renderer3 cellToggled $ \pathStr -> do + let (i:_) = stringToTreePath pathStr + val <- listStoreGetValue model i + listStoreSetValue model i val { marked = not (marked val) } + + + -- enable interactive search + treeViewSetEnableSearch view True + treeViewSetSearchEqualFunc view $ Just $ \str iter -> do + (i:_) <- treeModelGetPath model iter + row <- listStoreGetValue model i + return (map toLower str `isPrefixOf` map toLower (name row)) + + containerAdd win view + widgetShowAll win + mainGUI diff --git a/demo/treeList/ListTest.glade b/demo/treeList/ListTest.glade new file mode 100644 --- /dev/null +++ b/demo/treeList/ListTest.glade @@ -0,0 +1,1404 @@ + + + + + + + True + List Test + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + True + False + True + False + False + GDK_WINDOW_TYPE_HINT_NORMAL + GDK_GRAVITY_NORTH_WEST + True + + + + True + False + 0 + + + + True + True + GTK_POLICY_ALWAYS + GTK_POLICY_ALWAYS + GTK_SHADOW_IN + GTK_CORNER_TOP_LEFT + + + + True + True + True + False + False + True + False + False + False + + + + + 0 + True + True + + + + + + True + False + 0 + + + + 8 + True + False + 12 + + + + True + True + True + 0 + + + + 2 + True + 3 + 2 + False + 2 + 18 + + + + True + True + 1 + 0 + True + GTK_UPDATE_ALWAYS + True + False + 1 0 100 1 10 10 + + + 1 + 2 + 1 + 2 + + + + + + + True + True + GTK_RELIEF_NORMAL + True + False + False + True + + + 1 + 2 + 2 + 3 + fill + + + + + + + True + String value: + False + False + GTK_JUSTIFY_LEFT + False + False + 1 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + 1 + 0 + 1 + + + + + + + True + Number value: + False + False + GTK_JUSTIFY_LEFT + False + False + 1 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + 1 + 1 + 2 + + + + + + + True + Boolean value: + False + False + GTK_JUSTIFY_LEFT + False + False + 1 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + 1 + 2 + 3 + + + + + + + True + True + True + True + 0 + + True + * + False + + + 1 + 2 + 0 + 1 + expand|shrink|fill + + + + + + + + + True + <b>Value</b> + False + True + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + label_item + + + + + 0 + False + False + + + + + + True + True + True + 0 + + + + 4 + True + False + 2 + + + + True + True + 0 + + + + True + True + insert + True + GTK_RELIEF_NORMAL + True + + + 0 + True + True + + + + + + True + new entry at + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + True + + + + + + True + True + 1 + 0 + False + GTK_UPDATE_ALWAYS + False + False + 1 0 100 1 10 10 + + + 4 + False + False + + + + + 0 + True + True + + + + + + True + True + 0 + + + + True + True + prepend + True + GTK_RELIEF_NORMAL + True + + + 0 + True + True + + + + + + True + new entry + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + True + + + + + + True + + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + 0 + True + True + + + + + + True + True + 0 + + + + True + True + append + True + GTK_RELIEF_NORMAL + True + + + 0 + True + True + + + + + + True + new entry + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + True + + + + + + True + + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + 0 + True + True + + + + + + True + True + 0 + + + + True + True + update + True + GTK_RELIEF_NORMAL + True + + + 0 + True + True + + + + + + True + entry + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + True + + + + + + True + True + 1 + 0 + False + GTK_UPDATE_ALWAYS + False + False + 1 0 100 1 10 10 + + + 0 + False + False + + + + + 0 + True + True + + + + + + + + True + <b>Insert and Update</b> + False + True + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + label_item + + + + + 0 + False + False + + + + + + True + True + True + 0 + + + + True + False + 2 + + + + 4 + True + True + 0 + + + + 54 + True + True + delete + True + GTK_RELIEF_NORMAL + True + + + 0 + False + False + + + + + + True + entry + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + True + + + + + + True + True + 1 + 0 + False + GTK_UPDATE_ALWAYS + False + False + 1 0 100 1 10 10 + + + 0 + False + False + + + + + + True + + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + + True + + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + 0 + True + True + + + + + + 4 + True + True + 0 + + + + True + True + clear + True + GTK_RELIEF_NORMAL + True + + + 0 + False + True + + + + + + True + all + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + True + + + + + + True + + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + + True + + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + + True + + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + 0 + True + True + + + + + + + + True + <b>Delete</b> + False + True + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + label_item + + + + + 0 + False + False + + + + + + True + True + False + 0 + + + + 4 + True + False + 2 + + + + True + True + 0 + + + + 54 + True + True + move + True + GTK_RELIEF_NORMAL + True + + + 0 + False + False + + + + + + True + entry + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + True + + + + + + True + True + 1 + 0 + False + GTK_UPDATE_ALWAYS + False + False + 1 0 100 1 10 10 + + + 0 + True + False + + + + + + True + before + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + True + + + + + + True + True + 1 + 0 + False + GTK_UPDATE_ALWAYS + False + False + 1 0 100 1 10 10 + + + 0 + True + False + + + + + 0 + False + False + + + + + + True + True + 0 + + + + 54 + True + True + move + True + GTK_RELIEF_NORMAL + True + + + 0 + False + False + + + + + + True + entry + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + True + + + + + + True + True + 1 + 0 + False + GTK_UPDATE_ALWAYS + False + False + 1 0 100 1 10 10 + + + 0 + True + False + + + + + + True + after + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + True + + + + + + True + True + 1 + 0 + False + GTK_UPDATE_ALWAYS + False + False + 1 0 100 1 10 10 + + + 0 + True + False + + + + + 0 + False + False + + + + + + + + True + <b>Move</b> + False + True + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + label_item + + + + + 0 + False + False + + + + + + True + True + False + 0 + + + + 4 + True + True + 0 + + + + 54 + True + True + swap + True + GTK_RELIEF_NORMAL + True + + + 0 + False + False + + + + + + True + entry + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + True + + + + + + True + True + 1 + 0 + False + GTK_UPDATE_ALWAYS + False + False + 1 0 100 1 10 10 + + + 0 + False + False + + + + + + True + with + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + True + + + + + + True + True + 1 + 0 + False + GTK_UPDATE_ALWAYS + False + False + 1 0 100 1 10 10 + + + 0 + False + False + + + + + + + + True + <b>Swap</b> + False + True + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + label_item + + + + + 0 + False + False + + + + + + True + True + False + 0 + + + + + + + + True + <b>Reorder</b> + False + True + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + label_item + + + + + 0 + False + False + + + + + 0 + False + False + + + + + 0 + False + True + + + + + + + diff --git a/demo/treeList/ListTest.hs b/demo/treeList/ListTest.hs new file mode 100644 --- /dev/null +++ b/demo/treeList/ListTest.hs @@ -0,0 +1,102 @@ +module Main where + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Glade +import Graphics.UI.Gtk.ModelView as New + +data Phone = Phone { name :: String, number :: Int, marked :: Bool } + +main = do + initGUI + Just xml <- xmlNew "ListTest.glade" + + win <- xmlGetWidget xml castToWindow "window" + onDestroy win mainQuit + + view <- xmlGetWidget xml castToTreeView "view" + + stringValue <- xmlGetWidget xml castToEntry "stringValue" + intValue <- xmlGetWidget xml castToSpinButton "intValue" + boolValue <- xmlGetWidget xml castToCheckButton "boolValue" + + insertButton <- xmlGetWidget xml castToButton "insert" + prependButton <- xmlGetWidget xml castToButton "prepend" + appendButton <- xmlGetWidget xml castToButton "append" + updateButton <- xmlGetWidget xml castToButton "update" + newIndex <- xmlGetWidget xml castToSpinButton "newIndex" + updateIndex <- xmlGetWidget xml castToSpinButton "updateIndex" + + removeButton <- xmlGetWidget xml castToButton "remove" + clearButton <- xmlGetWidget xml castToButton "clear" + removeIndex <- xmlGetWidget xml castToSpinButton "removeIndex" + + -- create a new list store + store <- storeImpl + New.treeViewSetModel view store + setupView view store + + let getValues = do + name <- entryGetText stringValue + number <- spinButtonGetValue intValue + marked <- toggleButtonGetActive boolValue + return Phone { + name = name, + number = floor number, + marked = marked + } + + onClicked prependButton $ getValues >>= New.listStorePrepend store + onClicked appendButton $ getValues >>= New.listStoreAppend store >> return () + + onClicked insertButton $ do + value <- getValues + index <- fmap floor $ spinButtonGetValue newIndex + New.listStoreInsert store index value + + onClicked updateButton $ do + value <- getValues + index <- fmap floor $ spinButtonGetValue updateIndex + New.listStoreSetValue store index value + + onClicked removeButton $ do + index <- fmap floor $ spinButtonGetValue removeIndex + New.listStoreRemove store index + + onClicked clearButton $ New.listStoreClear store + + New.treeViewSetReorderable view True + +-- containerAdd win view + widgetShowAll win + mainGUI + +setupView view model = do + New.treeViewSetHeadersVisible view True + + -- add a couple columns + renderer1 <- New.cellRendererTextNew + col1 <- New.treeViewColumnNew + New.treeViewColumnPackStart col1 renderer1 True + New.cellLayoutSetAttributes col1 renderer1 model $ \row -> [ New.cellText := name row ] + New.treeViewColumnSetTitle col1 "String column" + New.treeViewAppendColumn view col1 + + renderer2 <- New.cellRendererTextNew + col2 <- New.treeViewColumnNew + New.treeViewColumnPackStart col2 renderer2 True + New.cellLayoutSetAttributes col2 renderer2 model $ \row -> [ New.cellText := show (number row) ] + New.treeViewColumnSetTitle col2 "Int column" + New.treeViewAppendColumn view col2 + + renderer3 <- New.cellRendererToggleNew + col3 <- New.treeViewColumnNew + New.treeViewColumnPackStart col3 renderer3 True + New.cellLayoutSetAttributes col3 renderer3 model $ \row -> [ New.cellToggleActive := marked row ] + New.treeViewColumnSetTitle col3 "Check box column" + New.treeViewAppendColumn view col3 + +storeImpl = + New.listStoreNew + [Phone { name = "Foo", number = 12345, marked = False } + ,Phone { name = "Bar", number = 67890, marked = True } + ,Phone { name = "Baz", number = 39496, marked = False }] diff --git a/demo/treeList/ListText.hs b/demo/treeList/ListText.hs new file mode 100644 --- /dev/null +++ b/demo/treeList/ListText.hs @@ -0,0 +1,78 @@ +import Graphics.UI.Gtk +import Data.Char +import Data.List +import Data.Maybe + +data RowInfo = RowInfo { rowString :: String, rowCase :: Maybe Bool } + +mkCase Nothing str = str +mkCase (Just False) str = map toLower str +mkCase (Just True) str = map toUpper str + +advCase Nothing = Just False +advCase (Just False) = Just True +advCase (Just True) = Nothing + +main :: IO () +main = do + unsafeInitGUIForThreadedRTS + win <- windowNew + win `on` objectDestroy $ mainQuit + + content <- readFile "ListText.hs" + + model <- listStoreNew (map (\r -> RowInfo r Nothing) (lines content)) + view <- treeViewNewWithModel model + + -- add a column showing the index + col <- treeViewColumnNew + treeViewAppendColumn view col + + cell <- cellRendererTextNew + cellLayoutPackStart col cell True + cellLayoutSetAttributeFunc col cell model $ \(TreeIter _ n _ _) -> + set cell [cellText := show n] + set col [treeViewColumnTitle := "line", + treeViewColumnReorderable := True ] + + -- add a column showing the line in the file + col <- treeViewColumnNew + treeViewAppendColumn view col + set col [treeViewColumnTitle := "line in file", + treeViewColumnReorderable := True ] + + cell <- cellRendererTextNew + cellLayoutPackStart col cell True + cellLayoutSetAttributes col cell model $ + \row -> [cellText := mkCase (rowCase row) (rowString row)] + + -- add a column showing if it is forced to a specific case + col <- treeViewColumnNew + treeViewAppendColumn view col + set col [treeViewColumnTitle := "case", + treeViewColumnReorderable := True ] + + cell <- cellRendererToggleNew + cellLayoutPackStart col cell True + cellLayoutSetAttributes col cell model $ + \row -> [cellToggleActive := fromMaybe False (rowCase row), + cellToggleInconsistent := rowCase row==Nothing] + cell `on` cellToggled $ \tpStr -> do + let [i] = stringToTreePath tpStr + row@RowInfo { rowCase = c } <- listStoreGetValue model i + listStoreSetValue model i row { rowCase = advCase c } + + -- to annoy the user: don't allow any columns to be dropped at the far right + treeViewSetColumnDragFunction view $ Just $ \_ rCol _ -> do + return (rCol /= Nothing) + + treeViewSetSearchEqualFunc view $ Just $ \str (TreeIter _ n _ _) -> do + row <- listStoreGetValue model (fromIntegral n) + return (map toLower str `isPrefixOf` map toLower (filter isAlphaNum (rowString row))) + + swin <- scrolledWindowNew Nothing Nothing + set swin [ containerChild := view ] + set win [ containerChild := swin ] + widgetShowAll win + mainGUI + diff --git a/demo/treeList/Makefile b/demo/treeList/Makefile new file mode 100644 --- /dev/null +++ b/demo/treeList/Makefile @@ -0,0 +1,45 @@ + +PROGS = listdemo treedemo listtest treetest dirlist treesort completion \ + listdnd filterdemo listtext + +SOURCES = ListDemo.hs TreeDemo.hs ListTest.hs TreeTest.hs DirList.hs \ + TreeSort.hs Completion.hs ListDND.hs FilterDemo.hs ListText.hs + +all : $(PROGS) + +listdemo : ListDemo.hs + $(HC_RULE) + +treedemo : TreeDemo.hs + $(HC_RULE) + +listtest : ListTest.hs + $(HC_RULE) + +treetest : TreeTest.hs + $(HC_RULE) + +dirlist : DirList.hs + $(HC_RULE) + +treesort : TreeSort.hs + $(HC_RULE) + +completion : Completion.hs + $(HC_RULE) + +listdnd : ListDND.hs + $(HC_RULE) + +filterdemo : FilterDemo.hs + $(HC_RULE) + +listtext : ListText.hs + $(HC_RULE) + +HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS) + +HC=ghc diff --git a/demo/treeList/TreeDemo.hs b/demo/treeList/TreeDemo.hs new file mode 100644 --- /dev/null +++ b/demo/treeList/TreeDemo.hs @@ -0,0 +1,68 @@ +module Main where + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.ModelView as New + +import qualified Data.Tree as Tree + +data Phone = Phone { name :: String, number :: Int, marked :: Bool } + +main = do + initGUI + + win <- windowNew + onDestroy win mainQuit + + -- create a new tree model + model <- storeImpl + view <- New.treeViewNewWithModel model + + New.treeViewSetHeadersVisible view True + + -- add three columns + col1 <- New.treeViewColumnNew + col2 <- New.treeViewColumnNew + col3 <- New.treeViewColumnNew + + New.treeViewColumnSetTitle col1 "String column" + New.treeViewColumnSetTitle col2 "Int column" + New.treeViewColumnSetTitle col3 "Bool column" + + renderer1 <- New.cellRendererTextNew + renderer2 <- New.cellRendererTextNew + renderer3 <- New.cellRendererToggleNew + + New.cellLayoutPackStart col1 renderer1 True + New.cellLayoutPackStart col2 renderer2 True + New.cellLayoutPackStart col3 renderer3 True + + New.cellLayoutSetAttributes col1 renderer1 model $ \row -> [ New.cellText := name row ] + New.cellLayoutSetAttributes col2 renderer2 model $ \row -> [ New.cellText := show (number row) ] + New.cellLayoutSetAttributes col3 renderer3 model $ \row -> [ New.cellToggleActive := marked row ] + + New.treeViewAppendColumn view col1 + New.treeViewAppendColumn view col2 + New.treeViewAppendColumn view col3 + + containerAdd win view + widgetShowAll win + mainGUI + +storeImpl = + New.treeStoreNew + [Tree.Node { + Tree.rootLabel = Phone { name = "Foo", number = 1, marked = False }, + Tree.subForest = [leafNode Phone { name = "Bar", number = 11, marked = True } + ,leafNode Phone { name = "Baz", number = 12, marked = False }] + }, + Tree.Node { + Tree.rootLabel = Phone { name = "Foo", number = 2, marked = False }, + Tree.subForest = [leafNode Phone { name = "Bar", number = 21, marked = True } + ,leafNode Phone { name = "Baz", number = 22, marked = False }] + }, + Tree.Node { + Tree.rootLabel = Phone { name = "Foo", number = 3, marked = False }, + Tree.subForest = [leafNode Phone { name = "Bar", number = 31, marked = True } + ,leafNode Phone { name = "Baz", number = 32, marked = False }] + }] + where leafNode a = Tree.Node { Tree.rootLabel = a, Tree.subForest = [] } diff --git a/demo/treeList/TreeSort.hs b/demo/treeList/TreeSort.hs new file mode 100644 --- /dev/null +++ b/demo/treeList/TreeSort.hs @@ -0,0 +1,85 @@ +import Graphics.UI.Gtk +import Graphics.UI.Gtk.ModelView as New +import Data.Tree + +main = do + initGUI + win <- windowNew + -- Create a tree model with some unsorted data. + rawmodel <- New.treeStoreNew + [Node ("zoo",8) [], Node ("foo",5) [], + Node ("bar",20) [], Node ("baz",2) []] + + -- Create a sorting proxy model, that is, a model that permutates the + -- rows of a different model such that they appear to be sorted. + model <- New.treeModelSortNewWithModel rawmodel + + -- Define two sorting functions, one being the default sorting function and + -- the other one being the sorting function for the 'SortColumnId' 2. + -- 'SortColumnId's are arbitrary positive numbers, i.e., we could have chosen + -- any other unique number. + New.treeSortableSetDefaultSortFunc model $ \iter1 iter2 -> do + (t1,_) <- New.treeModelGetRow rawmodel iter1 + (t2,_) <- New.treeModelGetRow rawmodel iter2 + return (compare t1 t2) + New.treeSortableSetSortFunc model 2 $ \iter1 iter2 -> do + (_,n1) <- New.treeModelGetRow rawmodel iter1 + (_,n2) <- New.treeModelGetRow rawmodel iter2 + return (compare n1 n2) + + -- Create the view. + view <- New.treeViewNewWithModel model + + -- Create and insert two columns, one with the heading Name, one with the + -- heading Number. Associate the 'SortColumnId' 2 with the latter column such + -- that clicking on the Number header will sort the rows by the numbers. + col <- New.treeViewColumnNew + New.treeViewColumnSetTitle col "Name" + rend <- New.cellRendererTextNew + New.cellLayoutPackStart col rend True + New.cellLayoutSetAttributeFunc col rend model $ \iter -> do + cIter <- New.treeModelSortConvertIterToChildIter model iter + (n,_) <- New.treeModelGetRow rawmodel cIter + set rend [New.cellText := n] + New.treeViewAppendColumn view col + + col' <- New.treeViewColumnNew + New.treeViewColumnSetTitle col' "Number" + rend <- New.cellRendererTextNew + New.cellLayoutPackStart col' rend True + New.cellLayoutSetAttributeFunc col' rend model $ \iter -> do + cIter <- New.treeModelSortConvertIterToChildIter model iter + (_,c) <- New.treeModelGetRow rawmodel cIter + set rend [New.cellText := show c] + New.treeViewAppendColumn view col' + New.treeViewColumnSetSortColumnId col' 2 + + -- Create a button that shows information on the current state of the sorting + -- settings. + button <- buttonNewWithLabel "Dump Info" + button `onClicked` do + sId <- New.treeViewColumnGetSortColumnId col + putStrLn ("tvc1 sort id is "++show sId) + sId <- New.treeViewColumnGetSortColumnId col' + putStrLn ("tvc2 sort id is "++show sId) + sId <- New.treeSortableGetSortColumnId model + putStrLn ("sort id is "++show sId) + -- Show all entries of the proxy model + let recurse Nothing = return () + recurse (Just iter) = do + cIter <- New.treeModelSortConvertIterToChildIter model iter + row <- New.treeModelGetRow rawmodel cIter + putStrLn ("iter "++show cIter++": "++show row) + mIter <- New.treeModelIterNext model iter + recurse mIter + mIter <- New.treeModelGetIterFirst model + recurse mIter + + -- Put it all together. + vBox <- vBoxNew False 3 + boxPackStartDefaults vBox view + boxPackEnd vBox button PackNatural 0 + containerAdd win vBox + widgetShowAll win + win `onDestroy` mainQuit + mainGUI diff --git a/demo/treeList/TreeTest.glade b/demo/treeList/TreeTest.glade new file mode 100644 --- /dev/null +++ b/demo/treeList/TreeTest.glade @@ -0,0 +1,1108 @@ + + + + + + + True + Tree Test + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + True + False + True + False + False + GDK_WINDOW_TYPE_HINT_NORMAL + GDK_GRAVITY_NORTH_WEST + True + False + + + + True + False + 0 + + + + True + True + GTK_POLICY_ALWAYS + GTK_POLICY_ALWAYS + GTK_SHADOW_IN + GTK_CORNER_TOP_LEFT + + + + True + True + True + False + False + True + False + False + False + + + + + 0 + True + True + + + + + + 8 + True + False + 12 + + + + True + True + True + 0 + + + + 2 + True + 3 + 2 + False + 4 + 18 + + + + True + True + 1 + 0 + True + GTK_UPDATE_ALWAYS + True + False + 1 0 100 1 10 10 + + + 1 + 2 + 1 + 2 + + + + + + + True + True + GTK_RELIEF_NORMAL + True + False + False + True + + + + + + + 1 + 2 + 2 + 3 + fill + + + + + + + True + True + True + True + 0 + + True + * + False + + + 1 + 2 + 0 + 1 + expand|shrink|fill + + + + + + + True + Number value: + False + False + GTK_JUSTIFY_LEFT + False + False + 1 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + 1 + 1 + 2 + + + + + + + + True + String value: + False + False + GTK_JUSTIFY_LEFT + False + False + 1 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + 1 + 0 + 1 + + + + + + + + True + Boolean value: + False + False + GTK_JUSTIFY_LEFT + False + False + 1 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + 1 + 2 + 3 + + + + + + + + + + True + <b>Value</b> + False + True + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + label_item + + + + + 0 + False + False + + + + + + True + True + True + 0 + + + + True + 2 + 3 + False + 4 + 2 + + + + True + True + insert + True + GTK_RELIEF_NORMAL + True + + + 0 + 1 + 0 + 1 + fill + + + + + + + True + new entry at + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 1 + 2 + 0 + 1 + fill + + + + + + + True + True + True + True + 0 + + True + * + False + 10 + + + 2 + 3 + 0 + 1 + + + + + + + True + True + update + True + GTK_RELIEF_NORMAL + True + + + 0 + 1 + 1 + 2 + fill + + + + + + + True + entry at + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 1 + 2 + 1 + 2 + fill + + + + + + + True + True + True + True + 0 + + True + * + False + 10 + + + 2 + 3 + 1 + 2 + + + + + + + + + True + <b>Insert and Update</b> + False + True + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + label_item + + + + + 0 + False + False + + + + + + True + True + True + 0 + + + + True + 2 + 3 + False + 4 + 2 + + + + 54 + True + True + delete + True + GTK_RELIEF_NORMAL + True + + + 0 + 1 + 0 + 1 + fill + + + + + + + True + True + clear + True + GTK_RELIEF_NORMAL + True + + + 0 + 1 + 1 + 2 + fill + + + + + + + True + entry + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 1 + 2 + 0 + 1 + fill + + + + + + + True + all + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 1 + 2 + 1 + 2 + fill + + + + + + + True + True + True + True + 0 + + True + * + False + 10 + + + 2 + 3 + 0 + 1 + + + + + + + + + True + <b>Delete</b> + False + True + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + label_item + + + + + 0 + False + False + + + + + + True + True + False + 0 + + + + True + 2 + 5 + False + 4 + 2 + + + + 54 + True + True + move + True + GTK_RELIEF_NORMAL + True + + + 0 + 1 + 0 + 1 + fill + + + + + + + 54 + True + True + move + True + GTK_RELIEF_NORMAL + True + + + 0 + 1 + 1 + 2 + fill + + + + + + + True + entry + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 1 + 2 + 0 + 1 + fill + + + + + + + True + entry + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 1 + 2 + 1 + 2 + fill + + + + + + + True + before + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 3 + 4 + 0 + 1 + fill + + + + + + + True + after + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 3 + 4 + 1 + 2 + fill + + + + + + + True + True + True + True + 0 + + True + * + False + 10 + + + 2 + 3 + 0 + 1 + + + + + + + True + True + True + True + 0 + + True + * + False + 10 + + + 4 + 5 + 0 + 1 + + + + + + + True + True + True + True + 0 + + True + * + False + 10 + + + 2 + 3 + 1 + 2 + + + + + + + True + True + True + True + 0 + + True + * + False + 10 + + + 4 + 5 + 1 + 2 + + + + + + + + + True + <b>Move</b> + False + True + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + label_item + + + + + 0 + False + False + + + + + + True + True + False + 0 + + + + 4 + True + False + 2 + + + + 54 + True + True + swap + True + GTK_RELIEF_NORMAL + True + + + 0 + False + False + + + + + + True + entry + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + True + + + + + + True + True + True + True + 0 + + True + * + False + 10 + + + 0 + True + True + + + + + + True + with + False + False + GTK_JUSTIFY_LEFT + False + False + 0 + 0.5 + 4 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + True + + + + + + True + True + True + True + 0 + + True + * + False + 10 + + + 0 + True + True + + + + + + + + True + <b>Swap</b> + False + True + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + label_item + + + + + 0 + False + False + + + + + + True + True + False + 0 + + + + + + + + True + <b>Reorder</b> + False + True + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + label_item + + + + + 0 + False + False + + + + + 0 + False + True + + + + + + + diff --git a/demo/treeList/TreeTest.hs b/demo/treeList/TreeTest.hs new file mode 100644 --- /dev/null +++ b/demo/treeList/TreeTest.hs @@ -0,0 +1,115 @@ +module Main where + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Glade +import Graphics.UI.Gtk.ModelView as New + +import qualified Data.Tree as Tree + +data Phone = Phone { name :: String, number :: Int, marked :: Bool } + +main = do + initGUI + Just xml <- xmlNew "TreeTest.glade" + + win <- xmlGetWidget xml castToWindow "window" + onDestroy win mainQuit + + view <- xmlGetWidget xml castToTreeView "view" + + stringValue <- xmlGetWidget xml castToEntry "stringValue" + intValue <- xmlGetWidget xml castToSpinButton "intValue" + boolValue <- xmlGetWidget xml castToCheckButton "boolValue" + + insertButton <- xmlGetWidget xml castToButton "insert" + updateButton <- xmlGetWidget xml castToButton "update" + newPath <- xmlGetWidget xml castToEntry "newPath" + updatePath <- xmlGetWidget xml castToEntry "updatePath" + + removeButton <- xmlGetWidget xml castToButton "remove" + clearButton <- xmlGetWidget xml castToButton "clear" + removePath <- xmlGetWidget xml castToEntry "removePath" + + -- create a new list store + store <- storeImpl + New.treeViewSetModel view store + setupView view store + + let getValues = do + name <- entryGetText stringValue + number <- spinButtonGetValue intValue + marked <- toggleButtonGetActive boolValue + return Phone { + name = name, + number = floor number, + marked = marked + } + + onClicked insertButton $ do + value <- getValues + path <- fmap read $ get newPath entryText + New.treeStoreInsert store (init path) (last path) value + + onClicked updateButton $ do + value <- getValues + path <- fmap read $ get updatePath entryText + New.treeStoreSetValue store path value + + onClicked removeButton $ do + path <- fmap read $ get removePath entryText + New.treeStoreRemove store path + return () + + onClicked clearButton $ New.treeStoreClear store + + New.treeViewSetReorderable view True + + widgetShowAll win + mainGUI + +setupView view model = do + New.treeViewSetHeadersVisible view True + + -- add three columns + col1 <- New.treeViewColumnNew + col2 <- New.treeViewColumnNew + col3 <- New.treeViewColumnNew + + New.treeViewColumnSetTitle col1 "String column" + New.treeViewColumnSetTitle col2 "Int column" + New.treeViewColumnSetTitle col3 "Bool column" + + renderer1 <- New.cellRendererTextNew + renderer2 <- New.cellRendererTextNew + renderer3 <- New.cellRendererToggleNew + + New.cellLayoutPackStart col1 renderer1 True + New.cellLayoutPackStart col2 renderer2 True + New.cellLayoutPackStart col3 renderer3 True + + New.cellLayoutSetAttributes col1 renderer1 model $ \row -> [ New.cellText := name row ] + New.cellLayoutSetAttributes col2 renderer2 model $ \row -> [ New.cellText := show (number row) ] + New.cellLayoutSetAttributes col3 renderer3 model $ \row -> [ New.cellToggleActive := marked row ] + + New.treeViewAppendColumn view col1 + New.treeViewAppendColumn view col2 + New.treeViewAppendColumn view col3 + +storeImpl = + New.treeStoreNew + [Tree.Node { + Tree.rootLabel = Phone { name = "Foo", number = 1, marked = False }, + Tree.subForest = [leafNode Phone { name = "Bar", number = 11, marked = True } + ,leafNode Phone { name = "Baz", number = 12, marked = False }] + }, + Tree.Node { + Tree.rootLabel = Phone { name = "Foo", number = 2, marked = False }, + Tree.subForest = [leafNode Phone { name = "Bar", number = 21, marked = True } + ,leafNode Phone { name = "Baz", number = 22, marked = False }] + }, + Tree.Node { + Tree.rootLabel = Phone { name = "Foo", number = 3, marked = False }, + Tree.subForest = [leafNode Phone { name = "Bar", number = 31, marked = True } + ,leafNode Phone { name = "Baz", number = 32, marked = False }] + }] + where leafNode a = Tree.Node { Tree.rootLabel = a, Tree.subForest = [] } diff --git a/demo/treeList/resListDND/desktop.png b/demo/treeList/resListDND/desktop.png new file mode 100644 Binary files /dev/null and b/demo/treeList/resListDND/desktop.png differ diff --git a/demo/treeList/resListDND/laptop.png b/demo/treeList/resListDND/laptop.png new file mode 100644 Binary files /dev/null and b/demo/treeList/resListDND/laptop.png differ diff --git a/demo/treeList/resListDND/laptopSmall.png b/demo/treeList/resListDND/laptopSmall.png new file mode 100644 Binary files /dev/null and b/demo/treeList/resListDND/laptopSmall.png differ diff --git a/demo/treeList/resListDND/printer.png b/demo/treeList/resListDND/printer.png new file mode 100644 Binary files /dev/null and b/demo/treeList/resListDND/printer.png differ diff --git a/demo/treeList/resListDND/server.png b/demo/treeList/resListDND/server.png new file mode 100644 Binary files /dev/null and b/demo/treeList/resListDND/server.png differ diff --git a/demo/treeList/resListDND/tower.png b/demo/treeList/resListDND/tower.png new file mode 100644 Binary files /dev/null and b/demo/treeList/resListDND/tower.png differ diff --git a/demo/treeList/rgb.txt b/demo/treeList/rgb.txt new file mode 100644 --- /dev/null +++ b/demo/treeList/rgb.txt @@ -0,0 +1,753 @@ +! $Xorg: rgb.txt,v 1.3 2000/08/17 19:54:00 cpqbld Exp $ +255 250 250 snow +248 248 255 ghost white +248 248 255 GhostWhite +245 245 245 white smoke +245 245 245 WhiteSmoke +220 220 220 gainsboro +255 250 240 floral white +255 250 240 FloralWhite +253 245 230 old lace +253 245 230 OldLace +250 240 230 linen +250 235 215 antique white +250 235 215 AntiqueWhite +255 239 213 papaya whip +255 239 213 PapayaWhip +255 235 205 blanched almond +255 235 205 BlanchedAlmond +255 228 196 bisque +255 218 185 peach puff +255 218 185 PeachPuff +255 222 173 navajo white +255 222 173 NavajoWhite +255 228 181 moccasin +255 248 220 cornsilk +255 255 240 ivory +255 250 205 lemon chiffon +255 250 205 LemonChiffon +255 245 238 seashell +240 255 240 honeydew +245 255 250 mint cream +245 255 250 MintCream +240 255 255 azure +240 248 255 alice blue +240 248 255 AliceBlue +230 230 250 lavender +255 240 245 lavender blush +255 240 245 LavenderBlush +255 228 225 misty rose +255 228 225 MistyRose +255 255 255 white + 0 0 0 black + 47 79 79 dark slate gray + 47 79 79 DarkSlateGray + 47 79 79 dark slate grey + 47 79 79 DarkSlateGrey +105 105 105 dim gray +105 105 105 DimGray +105 105 105 dim grey +105 105 105 DimGrey +112 128 144 slate gray +112 128 144 SlateGray +112 128 144 slate grey +112 128 144 SlateGrey +119 136 153 light slate gray +119 136 153 LightSlateGray +119 136 153 light slate grey +119 136 153 LightSlateGrey +190 190 190 gray +190 190 190 grey +211 211 211 light grey +211 211 211 LightGrey +211 211 211 light gray +211 211 211 LightGray + 25 25 112 midnight blue + 25 25 112 MidnightBlue + 0 0 128 navy + 0 0 128 navy blue + 0 0 128 NavyBlue +100 149 237 cornflower blue +100 149 237 CornflowerBlue + 72 61 139 dark slate blue + 72 61 139 DarkSlateBlue +106 90 205 slate blue +106 90 205 SlateBlue +123 104 238 medium slate blue +123 104 238 MediumSlateBlue +132 112 255 light slate blue +132 112 255 LightSlateBlue + 0 0 205 medium blue + 0 0 205 MediumBlue + 65 105 225 royal blue + 65 105 225 RoyalBlue + 0 0 255 blue + 30 144 255 dodger blue + 30 144 255 DodgerBlue + 0 191 255 deep sky blue + 0 191 255 DeepSkyBlue +135 206 235 sky blue +135 206 235 SkyBlue +135 206 250 light sky blue +135 206 250 LightSkyBlue + 70 130 180 steel blue + 70 130 180 SteelBlue +176 196 222 light steel blue +176 196 222 LightSteelBlue +173 216 230 light blue +173 216 230 LightBlue +176 224 230 powder blue +176 224 230 PowderBlue +175 238 238 pale turquoise +175 238 238 PaleTurquoise + 0 206 209 dark turquoise + 0 206 209 DarkTurquoise + 72 209 204 medium turquoise + 72 209 204 MediumTurquoise + 64 224 208 turquoise + 0 255 255 cyan +224 255 255 light cyan +224 255 255 LightCyan + 95 158 160 cadet blue + 95 158 160 CadetBlue +102 205 170 medium aquamarine +102 205 170 MediumAquamarine +127 255 212 aquamarine + 0 100 0 dark green + 0 100 0 DarkGreen + 85 107 47 dark olive green + 85 107 47 DarkOliveGreen +143 188 143 dark sea green +143 188 143 DarkSeaGreen + 46 139 87 sea green + 46 139 87 SeaGreen + 60 179 113 medium sea green + 60 179 113 MediumSeaGreen + 32 178 170 light sea green + 32 178 170 LightSeaGreen +152 251 152 pale green +152 251 152 PaleGreen + 0 255 127 spring green + 0 255 127 SpringGreen +124 252 0 lawn green +124 252 0 LawnGreen + 0 255 0 green +127 255 0 chartreuse + 0 250 154 medium spring green + 0 250 154 MediumSpringGreen +173 255 47 green yellow +173 255 47 GreenYellow + 50 205 50 lime green + 50 205 50 LimeGreen +154 205 50 yellow green +154 205 50 YellowGreen + 34 139 34 forest green + 34 139 34 ForestGreen +107 142 35 olive drab +107 142 35 OliveDrab +189 183 107 dark khaki +189 183 107 DarkKhaki +240 230 140 khaki +238 232 170 pale goldenrod +238 232 170 PaleGoldenrod +250 250 210 light goldenrod yellow +250 250 210 LightGoldenrodYellow +255 255 224 light yellow +255 255 224 LightYellow +255 255 0 yellow +255 215 0 gold +238 221 130 light goldenrod +238 221 130 LightGoldenrod +218 165 32 goldenrod +184 134 11 dark goldenrod +184 134 11 DarkGoldenrod +188 143 143 rosy brown +188 143 143 RosyBrown +205 92 92 indian red +205 92 92 IndianRed +139 69 19 saddle brown +139 69 19 SaddleBrown +160 82 45 sienna +205 133 63 peru +222 184 135 burlywood +245 245 220 beige +245 222 179 wheat +244 164 96 sandy brown +244 164 96 SandyBrown +210 180 140 tan +210 105 30 chocolate +178 34 34 firebrick +165 42 42 brown +233 150 122 dark salmon +233 150 122 DarkSalmon +250 128 114 salmon +255 160 122 light salmon +255 160 122 LightSalmon +255 165 0 orange +255 140 0 dark orange +255 140 0 DarkOrange +255 127 80 coral +240 128 128 light coral +240 128 128 LightCoral +255 99 71 tomato +255 69 0 orange red +255 69 0 OrangeRed +255 0 0 red +255 105 180 hot pink +255 105 180 HotPink +255 20 147 deep pink +255 20 147 DeepPink +255 192 203 pink +255 182 193 light pink +255 182 193 LightPink +219 112 147 pale violet red +219 112 147 PaleVioletRed +176 48 96 maroon +199 21 133 medium violet red +199 21 133 MediumVioletRed +208 32 144 violet red +208 32 144 VioletRed +255 0 255 magenta +238 130 238 violet +221 160 221 plum +218 112 214 orchid +186 85 211 medium orchid +186 85 211 MediumOrchid +153 50 204 dark orchid +153 50 204 DarkOrchid +148 0 211 dark violet +148 0 211 DarkViolet +138 43 226 blue violet +138 43 226 BlueViolet +160 32 240 purple +147 112 219 medium purple +147 112 219 MediumPurple +216 191 216 thistle +255 250 250 snow1 +238 233 233 snow2 +205 201 201 snow3 +139 137 137 snow4 +255 245 238 seashell1 +238 229 222 seashell2 +205 197 191 seashell3 +139 134 130 seashell4 +255 239 219 AntiqueWhite1 +238 223 204 AntiqueWhite2 +205 192 176 AntiqueWhite3 +139 131 120 AntiqueWhite4 +255 228 196 bisque1 +238 213 183 bisque2 +205 183 158 bisque3 +139 125 107 bisque4 +255 218 185 PeachPuff1 +238 203 173 PeachPuff2 +205 175 149 PeachPuff3 +139 119 101 PeachPuff4 +255 222 173 NavajoWhite1 +238 207 161 NavajoWhite2 +205 179 139 NavajoWhite3 +139 121 94 NavajoWhite4 +255 250 205 LemonChiffon1 +238 233 191 LemonChiffon2 +205 201 165 LemonChiffon3 +139 137 112 LemonChiffon4 +255 248 220 cornsilk1 +238 232 205 cornsilk2 +205 200 177 cornsilk3 +139 136 120 cornsilk4 +255 255 240 ivory1 +238 238 224 ivory2 +205 205 193 ivory3 +139 139 131 ivory4 +240 255 240 honeydew1 +224 238 224 honeydew2 +193 205 193 honeydew3 +131 139 131 honeydew4 +255 240 245 LavenderBlush1 +238 224 229 LavenderBlush2 +205 193 197 LavenderBlush3 +139 131 134 LavenderBlush4 +255 228 225 MistyRose1 +238 213 210 MistyRose2 +205 183 181 MistyRose3 +139 125 123 MistyRose4 +240 255 255 azure1 +224 238 238 azure2 +193 205 205 azure3 +131 139 139 azure4 +131 111 255 SlateBlue1 +122 103 238 SlateBlue2 +105 89 205 SlateBlue3 + 71 60 139 SlateBlue4 + 72 118 255 RoyalBlue1 + 67 110 238 RoyalBlue2 + 58 95 205 RoyalBlue3 + 39 64 139 RoyalBlue4 + 0 0 255 blue1 + 0 0 238 blue2 + 0 0 205 blue3 + 0 0 139 blue4 + 30 144 255 DodgerBlue1 + 28 134 238 DodgerBlue2 + 24 116 205 DodgerBlue3 + 16 78 139 DodgerBlue4 + 99 184 255 SteelBlue1 + 92 172 238 SteelBlue2 + 79 148 205 SteelBlue3 + 54 100 139 SteelBlue4 + 0 191 255 DeepSkyBlue1 + 0 178 238 DeepSkyBlue2 + 0 154 205 DeepSkyBlue3 + 0 104 139 DeepSkyBlue4 +135 206 255 SkyBlue1 +126 192 238 SkyBlue2 +108 166 205 SkyBlue3 + 74 112 139 SkyBlue4 +176 226 255 LightSkyBlue1 +164 211 238 LightSkyBlue2 +141 182 205 LightSkyBlue3 + 96 123 139 LightSkyBlue4 +198 226 255 SlateGray1 +185 211 238 SlateGray2 +159 182 205 SlateGray3 +108 123 139 SlateGray4 +202 225 255 LightSteelBlue1 +188 210 238 LightSteelBlue2 +162 181 205 LightSteelBlue3 +110 123 139 LightSteelBlue4 +191 239 255 LightBlue1 +178 223 238 LightBlue2 +154 192 205 LightBlue3 +104 131 139 LightBlue4 +224 255 255 LightCyan1 +209 238 238 LightCyan2 +180 205 205 LightCyan3 +122 139 139 LightCyan4 +187 255 255 PaleTurquoise1 +174 238 238 PaleTurquoise2 +150 205 205 PaleTurquoise3 +102 139 139 PaleTurquoise4 +152 245 255 CadetBlue1 +142 229 238 CadetBlue2 +122 197 205 CadetBlue3 + 83 134 139 CadetBlue4 + 0 245 255 turquoise1 + 0 229 238 turquoise2 + 0 197 205 turquoise3 + 0 134 139 turquoise4 + 0 255 255 cyan1 + 0 238 238 cyan2 + 0 205 205 cyan3 + 0 139 139 cyan4 +151 255 255 DarkSlateGray1 +141 238 238 DarkSlateGray2 +121 205 205 DarkSlateGray3 + 82 139 139 DarkSlateGray4 +127 255 212 aquamarine1 +118 238 198 aquamarine2 +102 205 170 aquamarine3 + 69 139 116 aquamarine4 +193 255 193 DarkSeaGreen1 +180 238 180 DarkSeaGreen2 +155 205 155 DarkSeaGreen3 +105 139 105 DarkSeaGreen4 + 84 255 159 SeaGreen1 + 78 238 148 SeaGreen2 + 67 205 128 SeaGreen3 + 46 139 87 SeaGreen4 +154 255 154 PaleGreen1 +144 238 144 PaleGreen2 +124 205 124 PaleGreen3 + 84 139 84 PaleGreen4 + 0 255 127 SpringGreen1 + 0 238 118 SpringGreen2 + 0 205 102 SpringGreen3 + 0 139 69 SpringGreen4 + 0 255 0 green1 + 0 238 0 green2 + 0 205 0 green3 + 0 139 0 green4 +127 255 0 chartreuse1 +118 238 0 chartreuse2 +102 205 0 chartreuse3 + 69 139 0 chartreuse4 +192 255 62 OliveDrab1 +179 238 58 OliveDrab2 +154 205 50 OliveDrab3 +105 139 34 OliveDrab4 +202 255 112 DarkOliveGreen1 +188 238 104 DarkOliveGreen2 +162 205 90 DarkOliveGreen3 +110 139 61 DarkOliveGreen4 +255 246 143 khaki1 +238 230 133 khaki2 +205 198 115 khaki3 +139 134 78 khaki4 +255 236 139 LightGoldenrod1 +238 220 130 LightGoldenrod2 +205 190 112 LightGoldenrod3 +139 129 76 LightGoldenrod4 +255 255 224 LightYellow1 +238 238 209 LightYellow2 +205 205 180 LightYellow3 +139 139 122 LightYellow4 +255 255 0 yellow1 +238 238 0 yellow2 +205 205 0 yellow3 +139 139 0 yellow4 +255 215 0 gold1 +238 201 0 gold2 +205 173 0 gold3 +139 117 0 gold4 +255 193 37 goldenrod1 +238 180 34 goldenrod2 +205 155 29 goldenrod3 +139 105 20 goldenrod4 +255 185 15 DarkGoldenrod1 +238 173 14 DarkGoldenrod2 +205 149 12 DarkGoldenrod3 +139 101 8 DarkGoldenrod4 +255 193 193 RosyBrown1 +238 180 180 RosyBrown2 +205 155 155 RosyBrown3 +139 105 105 RosyBrown4 +255 106 106 IndianRed1 +238 99 99 IndianRed2 +205 85 85 IndianRed3 +139 58 58 IndianRed4 +255 130 71 sienna1 +238 121 66 sienna2 +205 104 57 sienna3 +139 71 38 sienna4 +255 211 155 burlywood1 +238 197 145 burlywood2 +205 170 125 burlywood3 +139 115 85 burlywood4 +255 231 186 wheat1 +238 216 174 wheat2 +205 186 150 wheat3 +139 126 102 wheat4 +255 165 79 tan1 +238 154 73 tan2 +205 133 63 tan3 +139 90 43 tan4 +255 127 36 chocolate1 +238 118 33 chocolate2 +205 102 29 chocolate3 +139 69 19 chocolate4 +255 48 48 firebrick1 +238 44 44 firebrick2 +205 38 38 firebrick3 +139 26 26 firebrick4 +255 64 64 brown1 +238 59 59 brown2 +205 51 51 brown3 +139 35 35 brown4 +255 140 105 salmon1 +238 130 98 salmon2 +205 112 84 salmon3 +139 76 57 salmon4 +255 160 122 LightSalmon1 +238 149 114 LightSalmon2 +205 129 98 LightSalmon3 +139 87 66 LightSalmon4 +255 165 0 orange1 +238 154 0 orange2 +205 133 0 orange3 +139 90 0 orange4 +255 127 0 DarkOrange1 +238 118 0 DarkOrange2 +205 102 0 DarkOrange3 +139 69 0 DarkOrange4 +255 114 86 coral1 +238 106 80 coral2 +205 91 69 coral3 +139 62 47 coral4 +255 99 71 tomato1 +238 92 66 tomato2 +205 79 57 tomato3 +139 54 38 tomato4 +255 69 0 OrangeRed1 +238 64 0 OrangeRed2 +205 55 0 OrangeRed3 +139 37 0 OrangeRed4 +255 0 0 red1 +238 0 0 red2 +205 0 0 red3 +139 0 0 red4 +255 20 147 DeepPink1 +238 18 137 DeepPink2 +205 16 118 DeepPink3 +139 10 80 DeepPink4 +255 110 180 HotPink1 +238 106 167 HotPink2 +205 96 144 HotPink3 +139 58 98 HotPink4 +255 181 197 pink1 +238 169 184 pink2 +205 145 158 pink3 +139 99 108 pink4 +255 174 185 LightPink1 +238 162 173 LightPink2 +205 140 149 LightPink3 +139 95 101 LightPink4 +255 130 171 PaleVioletRed1 +238 121 159 PaleVioletRed2 +205 104 137 PaleVioletRed3 +139 71 93 PaleVioletRed4 +255 52 179 maroon1 +238 48 167 maroon2 +205 41 144 maroon3 +139 28 98 maroon4 +255 62 150 VioletRed1 +238 58 140 VioletRed2 +205 50 120 VioletRed3 +139 34 82 VioletRed4 +255 0 255 magenta1 +238 0 238 magenta2 +205 0 205 magenta3 +139 0 139 magenta4 +255 131 250 orchid1 +238 122 233 orchid2 +205 105 201 orchid3 +139 71 137 orchid4 +255 187 255 plum1 +238 174 238 plum2 +205 150 205 plum3 +139 102 139 plum4 +224 102 255 MediumOrchid1 +209 95 238 MediumOrchid2 +180 82 205 MediumOrchid3 +122 55 139 MediumOrchid4 +191 62 255 DarkOrchid1 +178 58 238 DarkOrchid2 +154 50 205 DarkOrchid3 +104 34 139 DarkOrchid4 +155 48 255 purple1 +145 44 238 purple2 +125 38 205 purple3 + 85 26 139 purple4 +171 130 255 MediumPurple1 +159 121 238 MediumPurple2 +137 104 205 MediumPurple3 + 93 71 139 MediumPurple4 +255 225 255 thistle1 +238 210 238 thistle2 +205 181 205 thistle3 +139 123 139 thistle4 + 0 0 0 gray0 + 0 0 0 grey0 + 3 3 3 gray1 + 3 3 3 grey1 + 5 5 5 gray2 + 5 5 5 grey2 + 8 8 8 gray3 + 8 8 8 grey3 + 10 10 10 gray4 + 10 10 10 grey4 + 13 13 13 gray5 + 13 13 13 grey5 + 15 15 15 gray6 + 15 15 15 grey6 + 18 18 18 gray7 + 18 18 18 grey7 + 20 20 20 gray8 + 20 20 20 grey8 + 23 23 23 gray9 + 23 23 23 grey9 + 26 26 26 gray10 + 26 26 26 grey10 + 28 28 28 gray11 + 28 28 28 grey11 + 31 31 31 gray12 + 31 31 31 grey12 + 33 33 33 gray13 + 33 33 33 grey13 + 36 36 36 gray14 + 36 36 36 grey14 + 38 38 38 gray15 + 38 38 38 grey15 + 41 41 41 gray16 + 41 41 41 grey16 + 43 43 43 gray17 + 43 43 43 grey17 + 46 46 46 gray18 + 46 46 46 grey18 + 48 48 48 gray19 + 48 48 48 grey19 + 51 51 51 gray20 + 51 51 51 grey20 + 54 54 54 gray21 + 54 54 54 grey21 + 56 56 56 gray22 + 56 56 56 grey22 + 59 59 59 gray23 + 59 59 59 grey23 + 61 61 61 gray24 + 61 61 61 grey24 + 64 64 64 gray25 + 64 64 64 grey25 + 66 66 66 gray26 + 66 66 66 grey26 + 69 69 69 gray27 + 69 69 69 grey27 + 71 71 71 gray28 + 71 71 71 grey28 + 74 74 74 gray29 + 74 74 74 grey29 + 77 77 77 gray30 + 77 77 77 grey30 + 79 79 79 gray31 + 79 79 79 grey31 + 82 82 82 gray32 + 82 82 82 grey32 + 84 84 84 gray33 + 84 84 84 grey33 + 87 87 87 gray34 + 87 87 87 grey34 + 89 89 89 gray35 + 89 89 89 grey35 + 92 92 92 gray36 + 92 92 92 grey36 + 94 94 94 gray37 + 94 94 94 grey37 + 97 97 97 gray38 + 97 97 97 grey38 + 99 99 99 gray39 + 99 99 99 grey39 +102 102 102 gray40 +102 102 102 grey40 +105 105 105 gray41 +105 105 105 grey41 +107 107 107 gray42 +107 107 107 grey42 +110 110 110 gray43 +110 110 110 grey43 +112 112 112 gray44 +112 112 112 grey44 +115 115 115 gray45 +115 115 115 grey45 +117 117 117 gray46 +117 117 117 grey46 +120 120 120 gray47 +120 120 120 grey47 +122 122 122 gray48 +122 122 122 grey48 +125 125 125 gray49 +125 125 125 grey49 +127 127 127 gray50 +127 127 127 grey50 +130 130 130 gray51 +130 130 130 grey51 +133 133 133 gray52 +133 133 133 grey52 +135 135 135 gray53 +135 135 135 grey53 +138 138 138 gray54 +138 138 138 grey54 +140 140 140 gray55 +140 140 140 grey55 +143 143 143 gray56 +143 143 143 grey56 +145 145 145 gray57 +145 145 145 grey57 +148 148 148 gray58 +148 148 148 grey58 +150 150 150 gray59 +150 150 150 grey59 +153 153 153 gray60 +153 153 153 grey60 +156 156 156 gray61 +156 156 156 grey61 +158 158 158 gray62 +158 158 158 grey62 +161 161 161 gray63 +161 161 161 grey63 +163 163 163 gray64 +163 163 163 grey64 +166 166 166 gray65 +166 166 166 grey65 +168 168 168 gray66 +168 168 168 grey66 +171 171 171 gray67 +171 171 171 grey67 +173 173 173 gray68 +173 173 173 grey68 +176 176 176 gray69 +176 176 176 grey69 +179 179 179 gray70 +179 179 179 grey70 +181 181 181 gray71 +181 181 181 grey71 +184 184 184 gray72 +184 184 184 grey72 +186 186 186 gray73 +186 186 186 grey73 +189 189 189 gray74 +189 189 189 grey74 +191 191 191 gray75 +191 191 191 grey75 +194 194 194 gray76 +194 194 194 grey76 +196 196 196 gray77 +196 196 196 grey77 +199 199 199 gray78 +199 199 199 grey78 +201 201 201 gray79 +201 201 201 grey79 +204 204 204 gray80 +204 204 204 grey80 +207 207 207 gray81 +207 207 207 grey81 +209 209 209 gray82 +209 209 209 grey82 +212 212 212 gray83 +212 212 212 grey83 +214 214 214 gray84 +214 214 214 grey84 +217 217 217 gray85 +217 217 217 grey85 +219 219 219 gray86 +219 219 219 grey86 +222 222 222 gray87 +222 222 222 grey87 +224 224 224 gray88 +224 224 224 grey88 +227 227 227 gray89 +227 227 227 grey89 +229 229 229 gray90 +229 229 229 grey90 +232 232 232 gray91 +232 232 232 grey91 +235 235 235 gray92 +235 235 235 grey92 +237 237 237 gray93 +237 237 237 grey93 +240 240 240 gray94 +240 240 240 grey94 +242 242 242 gray95 +242 242 242 grey95 +245 245 245 gray96 +245 245 245 grey96 +247 247 247 gray97 +247 247 247 grey97 +250 250 250 gray98 +250 250 250 grey98 +252 252 252 gray99 +252 252 252 grey99 +255 255 255 gray100 +255 255 255 grey100 +169 169 169 dark grey +169 169 169 DarkGrey +169 169 169 dark gray +169 169 169 DarkGray +0 0 139 dark blue +0 0 139 DarkBlue +0 139 139 dark cyan +0 139 139 DarkCyan +139 0 139 dark magenta +139 0 139 DarkMagenta +139 0 0 dark red +139 0 0 DarkRed +144 238 144 light green +144 238 144 LightGreen diff --git a/demo/unicode/Arabic.hs b/demo/unicode/Arabic.hs new file mode 100644 --- /dev/null +++ b/demo/unicode/Arabic.hs @@ -0,0 +1,42 @@ +-- Example of an international dialog box. +import Graphics.UI.Gtk + +import Data.Char +import Control.Exception + +main :: IO () +main = do + initGUI + dia <- dialogNew + dialogAddButton dia stockYes ResponseYes + dialogAddButton dia stockNo ResponseNo + contain <- dialogGetUpper dia + theText <- labelNew Nothing + labelSetMarkup theText arabic + boxPackStartDefaults contain theText + widgetShowAll dia + res <- dialogRun dia + case res of + ResponseNo -> yell + _ -> return () + +arabic :: Markup +arabic = markSpan [FontSize (SizePoint 36)] $ + --"Is Haskell a "++markSpan [FontForeground "red"] "fantastic"++" language?"++ + -- Do you find Haskell a fantastic language? (language has a grammatical + -- mistake in it) + map chr [0x647,0x644,32,0x62A,0x62C,0x62F,0x646,32]++ + markSpan [FontForeground "red"] + (map chr [0x647,0x622,0x633,0x643,0x622,0x644])++ + map chr [32,0x644,0x63A,0x62A,32,0x645,0x62F,0x647,0x634,0x62A,0x61F] + +yell :: IO () +yell = do + dia <- dialogNew + dialogAddButton dia stockOk ResponseOk + contain <- dialogGetUpper dia + msg <- labelNew (Just "This is not an option.") + contain `boxPackStartDefaults` msg + widgetShow msg + dialogRun dia + return () diff --git a/demo/unicode/Makefile b/demo/unicode/Makefile new file mode 100644 --- /dev/null +++ b/demo/unicode/Makefile @@ -0,0 +1,11 @@ + +PROG = arabic +SOURCES = Arabic.hs + +$(PROG) : $(SOURCES) + $(HC) --make $< -o $@ $(HCFLAGS) + +clean: + rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG) + +HC=ghc diff --git a/gtk.cabal b/gtk.cabal --- a/gtk.cabal +++ b/gtk.cabal @@ -1,5 +1,5 @@ Name: gtk -Version: 0.11.0 +Version: 0.11.1 License: LGPL-2.1 License-file: COPYING Copyright: (c) 2001-2010 The Gtk2Hs Team @@ -16,17 +16,96 @@ for creating graphical user interfaces. Category: Graphics Tested-With: GHC == 6.10.4 -x-Types-File: Graphics/UI/Gtk/Types.chs -x-Types-ModName: Graphics.UI.Gtk.Types -x-Types-Forward: *System.Glib.GObject Graphics.UI.Gtk.General.Threading -x-Types-Destructor: objectUnrefFromMainloop Extra-Source-Files: wingtk.h Graphics/UI/Gtk/ModelView/Gtk2HsStore.h Graphics/UI/Gtk/General/hsgthread.h template-hsc-gtk2hs.h Gtk2HsSetup.hs marshal.list + hierarchy.list + +x-Types-File: Graphics/UI/Gtk/Types.chs +x-Types-ModName: Graphics.UI.Gtk.Types +x-Types-Forward: *System.Glib.GObject Graphics.UI.Gtk.General.Threading +x-Types-Destructor: objectUnrefFromMainloop +x-Types-Hierarchy: hierarchy.list +Data-Dir: demo +Data-Files: actionMenu/ActionMenu.hs + actionMenu/Makefile + + buttonbox/ButtonBox.hs + buttonbox/Makefile + + carsim/CarSim.hs + carsim/Makefile + + concurrent/Makefile + concurrent/Progress.hs + concurrent/ProgressThreadedRTS.hs + + embedded/Embedded.hs + embedded/Makefile + embedded/Notes.txt + embedded/Uzbl.hs + + fastdraw/FastDraw.hs + fastdraw/Makefile + + filechooser/FileChooserDemo.glade + filechooser/FileChooserDemo.hs + filechooser/Makefile + + fonts/Fonts.hs + fonts/Makefile + + graphic/Drawing.hs + graphic/Makefile + + gtkbuilder/GtkBuilderTest.hs + gtkbuilder/Makefile + gtkbuilder/simple.ui + + hello/Makefile + hello/World.hs + + inputmethod/Layout.hs + inputmethod/Makefile + + menu/ComboDemo.hs + menu/Makefile + menu/MenuDemo.hs + + statusicon/Makefile + statusicon/StatusIcon.hs + + treeList/Completion.hs + treeList/DirList.hs + treeList/FilterDemo.hs + treeList/ListDemo.hs + treeList/ListDND.hs + treeList/ListTest.glade + treeList/ListTest.hs + treeList/ListText.hs + treeList/Makefile + treeList/rgb.txt + treeList/TreeDemo.hs + treeList/TreeSort.hs + treeList/TreeTest.glade + treeList/TreeTest.hs + + treeList/resListDND/desktop.png + treeList/resListDND/laptop.png + treeList/resListDND/laptopSmall.png + treeList/resListDND/printer.png + treeList/resListDND/server.png + treeList/resListDND/tower.png + + unicode/Arabic.hs + unicode/Makefile + + demos.txt + Source-Repository head type: darcs location: http://code.haskell.org/gtk2hs/ @@ -43,12 +122,12 @@ Library build-depends: base >= 4 && < 5, - array, containers, haskell98, mtl, - glib >= 0.11 && < 0.12, - pango >= 0.11 && < 0.12, - cairo >= 0.11 && < 0.12 + array, containers, haskell98, mtl, bytestring, + glib >= 0.11.1 && < 0.12, + pango >= 0.11.1 && < 0.12, + cairo >= 0.11.1 && < 0.12 if flag(have-gio) - build-depends: gio >= 0.11 && < 0.12 + build-depends: gio >= 0.11.1 && < 0.12 cpp-options: -DHAVE_GIO build-tools: gtk2hsC2hs, gtk2hsHookGenerator, gtk2hsTypeGen @@ -159,6 +238,7 @@ Graphics.UI.Gtk.Misc.HandleBox Graphics.UI.Gtk.Misc.IMMulticontext Graphics.UI.Gtk.Misc.SizeGroup + Graphics.UI.Gtk.Misc.Tooltip Graphics.UI.Gtk.Misc.Tooltips Graphics.UI.Gtk.Misc.Viewport Graphics.UI.Gtk.ModelView @@ -230,7 +310,12 @@ extensions: ForeignFunctionInterface c-sources: Graphics/UI/Gtk/ModelView/Gtk2HsStore.c Graphics/UI/Gtk/General/hsgthread.c - + -- Due to http://hackage.haskell.org/trac/ghc/ticket/781 + -- we need to compile the hsgthread.c module with -fPIC to ensure that a global + -- variable in GLib that holds the address for the mutex lock and unlock functions + -- is accessed correctly. This bug only exists on x86-64 platforms. + if arch(x86_64) + cc-options: -fPIC x-Signals-File: Graphics/UI/Gtk/Signals.chs x-Signals-Modname: Graphics.UI.Gtk.Signals x-Signals-Types: marshal.list diff --git a/hierarchy.list b/hierarchy.list new file mode 100644 --- /dev/null +++ b/hierarchy.list @@ -0,0 +1,346 @@ +# This list is the result of a copy-and-paste from the GtkObject hierarchy +# html documentation. Deprecated widgets are uncommented. Some additional +# object have been defined at the end of the copied list. + +# The Gtk prefix of every object is removed, the other prefixes are +# kept. The indentation implies the object hierarchy. In case the +# type query function cannot be derived from the name or the type name +# is different, an alternative name and type query function can be +# specified by appending 'as typename, '. In case this +# function is not specified, the is converted to +# gtk__get_type where is where each upperscore +# letter is converted to an underscore and lowerletter. The underscore +# is omitted if an upperscore letter preceeded: GtkHButtonBox -> +# gtk_hbutton_box_get_type. The generation of a type can be +# conditional by appending 'if '. Such types are only produces if +# --tag= is given on the command line of TypeGenerator. + +# Before these conditions, two additional properties may be given: +# * noDestr : ignores the destructor given by the --destructor +# command line argument and uses 'objectUnref' +# * noEq : do not make this type an instance of Eq; used +# if a different equality instance is manually +# defined later + GObject + GdkDrawable + GdkWindow as DrawWindow, gdk_window_object_get_type +# GdkDrawableImplX11 +# GdkWindowImplX11 + GdkPixmap + GdkGLPixmap if gtkglext + GdkGLWindow if gtkglext + GdkColormap + GdkScreen if gtk-2.2 + GdkDisplay if gtk-2.2 + GdkVisual + GdkDevice + GtkSettings + GtkTextBuffer + GtkSourceBuffer if sourceview + GtkSourceBuffer if gtksourceview2 + GtkTextTag + GtkSourceTag if sourceview + GtkTextTagTable + GtkSourceTagTable if sourceview + GtkStyle + GtkRcStyle + GdkDragContext + GdkPixbuf noDestr + GdkPixbufAnimation noDestr + GdkPixbufSimpleAnim noDestr + GdkPixbufAnimationIter noDestr + GtkTextChildAnchor + GtkTextMark + GtkSourceMarker if sourceview + GtkSourceMark if gtksourceview2 + GtkObject + GtkWidget + GtkMisc + GtkLabel + GtkAccelLabel + GtkTipsQuery if deprecated + GtkArrow + GtkImage + GtkContainer + WebKitWebView as WebView, webkit_web_view_get_type if webkit + GtkBin + GtkAlignment + GtkFrame + GtkAspectFrame + GtkButton + GtkToggleButton + GtkCheckButton + GtkRadioButton + GtkColorButton if gtk-2.4 + GtkFontButton if gtk-2.4 + GtkOptionMenu if deprecated + GtkItem + GtkMenuItem + GtkCheckMenuItem + GtkRadioMenuItem + GtkTearoffMenuItem + GtkImageMenuItem + GtkSeparatorMenuItem + GtkListItem if deprecated +# GtkTreeItem + GtkWindow + GtkDialog + GtkAboutDialog if gtk-2.6 + GtkColorSelectionDialog + GtkFileSelection + GtkFileChooserDialog if gtk-2.4 + GtkFontSelectionDialog + GtkInputDialog + GtkMessageDialog + GtkPlug if plugNsocket + GtkEventBox + GtkHandleBox + GtkScrolledWindow + GtkViewport + GtkExpander if gtk-2.4 + GtkComboBox if gtk-2.4 + GtkComboBoxEntry if gtk-2.4 + GtkToolItem if gtk-2.4 + GtkToolButton if gtk-2.4 + GtkMenuToolButton if gtk-2.6 + GtkToggleToolButton if gtk-2.4 + GtkRadioToolButton if gtk-2.4 + GtkSeparatorToolItem if gtk-2.4 + GtkMozEmbed if mozembed + VteTerminal as Terminal if vte + GtkBox + GtkButtonBox + GtkHButtonBox + GtkVButtonBox + GtkVBox + GtkColorSelection + GtkFontSelection + GtkFileChooserWidget if gtk-2.4 + GtkHBox + GtkCombo if deprecated + GtkFileChooserButton if gtk-2.6 + GtkStatusbar + GtkCList if deprecated + GtkCTree if deprecated + GtkFixed + GtkPaned + GtkHPaned + GtkVPaned + GtkIconView if gtk-2.6 + GtkLayout + GtkList if deprecated + GtkMenuShell + GtkMenu + GtkMenuBar + GtkNotebook +# GtkPacker + GtkSocket if plugNsocket + GtkTable + GtkTextView + GtkSourceView if sourceview + GtkSourceView if gtksourceview2 + GtkToolbar + GtkTreeView + GtkCalendar + GtkCellView if gtk-2.6 + GtkDrawingArea + GtkEntry + GtkSpinButton + GtkRuler + GtkHRuler + GtkVRuler + GtkRange + GtkScale + GtkHScale + GtkVScale + GtkScrollbar + GtkHScrollbar + GtkVScrollbar + GtkSeparator + GtkHSeparator + GtkVSeparator + GtkInvisible +# GtkOldEditable +# GtkText + GtkPreview if deprecated +# Progress is deprecated, ProgressBar contains everything necessary +# GtkProgress + GtkProgressBar + GtkAdjustment + GtkIMContext + GtkIMMulticontext + GtkItemFactory if deprecated + GtkTooltips + +# These object were added by hand because they do not show up in the hierarchy +# chart. +# These are derived from GtkObject: + GtkTreeViewColumn + GtkCellRenderer + GtkCellRendererPixbuf + GtkCellRendererText + GtkCellRendererCombo if gtk-2.6 + GtkCellRendererToggle + GtkCellRendererProgress if gtk-2.6 + GtkFileFilter if gtk-2.4 + GtkBuilder if gtk-2.12 +# These are actually interfaces, but all objects that implement it are at +# least GObjects. + GtkCellLayout if gtk-2.4 + GtkTreeSortable if gtk-2.4 + GtkTooltip if gtk-2.12 +# These are derived from GObject: + GtkStatusIcon if gtk-2.10 + GtkTreeSelection + GtkTreeModel + GtkTreeStore + GtkListStore + GtkTreeModelSort + GtkTreeModelFilter if gtk-2.4 + GtkIconFactory + GtkIconTheme + GtkSizeGroup + GtkClipboard if gtk-2.2 + GtkAccelGroup + GtkAccelMap if gtk-2.4 + GtkEntryCompletion if gtk-2.4 + GtkAction if gtk-2.4 + GtkToggleAction if gtk-2.4 + GtkRadioAction if gtk-2.4 + GtkActionGroup if gtk-2.4 + GtkUIManager if gtk-2.4 + GtkWindowGroup + GtkSourceLanguage if sourceview + GtkSourceLanguage if gtksourceview2 + GtkSourceLanguagesManager if sourceview + GtkSourceLanguageManager if gtksourceview2 + GladeXML as GladeXML, glade_xml_get_type if libglade + GConfClient as GConf if gconf +# These ones are actualy interfaces, but interface implementations are GObjects + GtkEditable + GtkSourceStyle as SourceStyleObject if gtksourceview2 + GtkSourceStyleScheme if sourceview + GtkSourceStyleScheme if gtksourceview2 + GtkSourceStyleSchemeManager if gtksourceview2 + GtkFileChooser if gtk-2.4 +## This now became a GObject in version 2: + GdkGC as GC, gdk_gc_get_type +## These are Pango structures + PangoContext as PangoContext, pango_context_get_type if pango + PangoLayout as PangoLayoutRaw, pango_layout_get_type if pango + PangoFont as Font, pango_font_get_type if pango + PangoFontFamily as FontFamily, pango_font_family_get_type if pango + PangoFontFace as FontFace, pango_font_face_get_type if pango + PangoFontMap as FontMap, pango_font_face_get_type if pango + PangoFontset as FontSet, pango_fontset_get_type if pango +## This type is only available for PANGO_ENABLE_BACKEND compiled source +## PangoFontsetSimple as FontSetSimple, pango_fontset_simple_get_type + +## GtkGlExt classes + GdkGLContext if gtkglext + GdkGLConfig if gtkglext + GdkGLDrawable if gtkglext + +## GnomeVFS classes + GnomeVFSVolume as Volume, gnome_vfs_volume_get_type if gnomevfs + GnomeVFSDrive as Drive, gnome_vfs_drive_get_type if gnomevfs + GnomeVFSVolumeMonitor as VolumeMonitor, gnome_vfs_volume_monitor_get_type if gnomevfs + +## GIO classes +# Note on all the "as" clauses: the prefix G is unfortunate since it leads +# to two consecutive upper case letters which are not translated with an +# underscore each (e.g. GConf -> gconf, GtkHButtonBox -> gtk_hbutton_box). +# GUnixMountMonitor as UnixMountMonitor, g_unix_mount_monitor_get_type if gio + GOutputStream as OutputStream, g_output_stream_get_type if gio + GFilterOutputStream as FilterOutputStream, g_filter_output_stream_get_type if gio + GDataOutputStream as DataOutputStream, g_data_output_stream_get_type if gio + GBufferedOutputStream as BufferedOutputStream, g_buffered_output_stream_get_type if gio +# GUnixOutputStream as UnixOutputStream, g_unix_output_stream_get_type if gio + GFileOutputStream as FileOutputStream, g_file_output_stream_get_type if gio + GMemoryOutputStream as MemoryOutputStream, g_memory_output_stream_get_type if gio + GInputStream as InputStream, g_input_stream_get_type if gio +# GUnixInputStream as UnixInputStream, g_unix_input_stream_get_type if gio + GMemoryInputStream as MemoryInputStream, g_memory_input_stream_get_type if gio + GFilterInputStream as FilterInputStream, g_filter_input_stream_get_type if gio + GBufferedInputStream as BufferedInputStream, g_buffered_input_stream_get_type if gio + GDataInputStream as DataInputStream, g_data_input_stream_get_type if gio + GFileInputStream as FileInputStream, g_file_input_stream_get_type if gio +# GDesktopAppInfo as DesktopAppInfo, g_desktop_app_info_get_type if gio + GFileMonitor as FileMonitor, g_file_monitor_get_type if gio + GVfs as Vfs, g_vfs_get_type if gio + GMountOperation as MountOperation, g_mount_operation_get_type if gio + GThemedIcon as ThemedIcon, g_themed_icon_get_type if gio + GEmblem as Emblem, g_emblem_get_type if gio + GEmblemedIcon as EmblemedIcon, g_emblemed_icon_get_type if gio + GFileEnumerator as FileEnumerator, g_file_enumerator_get_type if gio + GFilenameCompleter as FilenameCompleter, g_filename_completer_get_type if gio + GFileIcon as FileIcon, g_file_icon_get_type if gio + GVolumeMonitor as VolumeMonitor, g_volume_monitor_get_type if gio + GCancellable as Cancellable, g_cancellable_get_type if gio + GSimpleAsyncResult as SimpleAsyncResult, g_async_result_get_type if gio + GFileInfo as FileInfo, g_file_info_get_type if gio + GAppLaunchContext as AppLaunchContext, g_app_launch_context_get_type if gio +## these are actually GInterfaces + GIcon as Icon, g_icon_get_type if gio + GSeekable as Seekable, g_seekable_get_type if gio + GAppInfo as AppInfo, g_app_info_get_type if gio + GVolume as Volume, g_volume_get_type if gio + GAsyncResult as AsyncResult, g_async_result_get_type if gio + GLoadableIcon as LoadableIcon, g_loadable_icon_get_type if gio + GDrive as Drive, g_drive_get_type if gio + GFile noEq as File, g_file_get_type if gio + GMount as Mount, g_mount_get_type if gio + +## GStreamer classes + GstObject as Object, gst_object_get_type if gstreamer + GstPad as Pad, gst_pad_get_type if gstreamer + GstGhostPad as GhostPad, gst_ghost_pad_get_type if gstreamer + GstPluginFeature as PluginFeature, gst_plugin_feature_get_type if gstreamer + GstElementFactory as ElementFactory, gst_element_factory_get_type if gstreamer + GstTypeFindFactory as TypeFindFactory, gst_type_find_factory_get_type if gstreamer + GstIndexFactory as IndexFactory, gst_index_factory_get_type if gstreamer + GstElement as Element, gst_element_get_type if gstreamer + GstBin as Bin, gst_bin_get_type if gstreamer + GstPipeline as Pipeline, gst_pipeline_get_type if gstreamer + GstImplementsInterface as ImplementsInterface, gst_implements_interface_get_type if gstreamer + GstTagSetter as TagSetter, gst_tag_setter_get_type if gstreamer + GstBaseSrc as BaseSrc, gst_base_src_get_type if gstreamer + GstPushSrc as PushSrc, gst_push_src_get_type if gstreamer + GstBaseSink as BaseSink, gst_base_sink_get_type if gstreamer + GstBaseTransform as BaseTransform, gst_base_transform_get_type if gstreamer + GstPlugin as Plugin, gst_plugin_get_type if gstreamer + GstRegistry as Registry, gst_registry_get_type if gstreamer + GstBus as Bus, gst_bus_get_type if gstreamer + GstClock as Clock, gst_clock_get_type if gstreamer + GstAudioClock as AudioClock, gst_audio_clock_get_type if gstreamer + GstSystemClock as SystemClock, gst_system_clock_get_type if gstreamer + GstNetClientClock as NetClientClock, gst_net_client_clock_get_type if gstreamer + GstIndex as Index, gst_index_get_type if gstreamer + GstPadTemplate as PadTemplate, gst_pad_template_get_type if gstreamer + GstTask as Task, gst_task_get_type if gstreamer + GstXML as XML, gst_xml_get_type if gstreamer + GstChildProxy as ChildProxy, gst_child_proxy_get_type if gstreamer + GstCollectPads as CollectPads, gst_collect_pads_get_type if gstreamer +## these are actually GInterfaces + GstURIHandler as URIHandler, gst_uri_handler_get_type if gstreamer + GstAdapter as Adapter, gst_adapter_get_type if gstreamer + GstController as Controller, gst_controller_get_type if gstreamer + + WebKitWebFrame as WebFrame, webkit_web_frame_get_type if webkit + WebKitWebSettings as WebSettings, webkit_web_settings_get_type if webkit + WebKitNetworkRequest as NetworkRequest, webkit_network_request_get_type if webkit + WebKitNetworkResponse as NetworkResponse, webkit_network_response_get_type if webkit + WebKitDownload as Download, webkit_download_get_type if webkit + WebKitWebBackForwardList as WebBackForwardList, webkit_web_back_forward_list_get_type if webkit + WebKitWebHistoryItem as WebHistoryItem, webkit_web_history_item_get_type if webkit + WebKitWebInspector as WebInspector, webkit_web_inspector_get_type if webkit + WebKitHitTestResult as HitTestResult, webkit_hit_test_result_get_type if webkit + WebKitSecurityOrigin as SecurityOrigin, webkit_security_origin_get_type if webkit + WebKitSoupAuthDialog as SoupAuthDialog, webkit_soup_auth_dialog_get_type if webkit + WebKitWebDatabase as WebDatabase, webkit_web_database_get_type if webkit + WebKitWebDataSource as WebDataSource, webkit_web_data_source_get_type if webkit + WebKitWebNavigationAction as WebNavigationAction, webkit_web_navigation_action_get_type if webkit + WebKitWebPolicyDecision as WebPolicyDecision, webkit_web_policy_decision_get_type if webkit + WebKitWebResource as WebResource, webkit_web_resource_get_type if webkit + WebKitWebWindowFeatures as WebWindowFeatures, webkit_web_window_features_get_type if webkit + diff --git a/marshal.list b/marshal.list --- a/marshal.list +++ b/marshal.list @@ -153,3 +153,5 @@ NONE:BOXED,INT # for TextBuffer NONE:BOXED,STRING +# For queryTooltip +BOOLEAN:TOBJECT,INT,INT,BOOLEAN,TOBJECT