diff --git a/Graphics/UI/Gtk.chs b/Graphics/UI/Gtk.chs --- a/Graphics/UI/Gtk.chs +++ b/Graphics/UI/Gtk.chs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- -*-haskell-*- -- GIMP Toolkit (GTK) -- diff --git a/Graphics/UI/Gtk/Abstract/IMContext.chs b/Graphics/UI/Gtk/Abstract/IMContext.chs --- a/Graphics/UI/Gtk/Abstract/IMContext.chs +++ b/Graphics/UI/Gtk/Abstract/IMContext.chs @@ -192,7 +192,7 @@ -- | Sets surrounding context around the insertion point and preedit string. -- This function is expected to be called in response to the --- 'IMContext'::retrieve_surrounding signal, and will likely have no effect if +-- 'imContextRetrieveSurrounding' signal, and will likely have no effect if -- called at other times. -- imContextSetSurrounding :: IMContextClass self => self 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 @@ -203,6 +203,7 @@ widgetGetAllocation, #endif widgetGetState, + widgetSetState, widgetGetSavedState, widgetGetSize, widgetEvent, @@ -223,6 +224,7 @@ widgetReceivesDefault, widgetCompositeChild, widgetStyle, + widgetState, widgetEvents, widgetExtensionEvents, widgetNoShowAll, @@ -389,7 +391,10 @@ import Graphics.UI.Gtk.General.Structs (Allocation, Rectangle(..) ,Requisition(..), Color, IconSize(..) ,Point - ,widgetGetState, widgetGetSavedState +#if !GTK_CHECK_VERSION(2,18,0) + ,widgetGetState +#endif + ,widgetGetSavedState ,widgetGetDrawWindow, widgetGetSize) import Graphics.UI.Gtk.Gdk.Events (Event(..), marshalEvent, marshExposeRect, @@ -834,7 +839,7 @@ -- the event mask is automatically adjusted so that he signal is emitted. -- This function is useful to disable the reception of the signal. It -- should be called whenever all signals receiving an 'Event' --- have been disconected. +-- have been disconnected. -- widgetDelEvents :: WidgetClass self => self -> [EventMask] -> IO () widgetDelEvents self events = do @@ -2150,6 +2155,29 @@ peek allocationPtr #endif +#if GTK_CHECK_VERSION(2,18,0) +-- | Retrieve the current state of the widget. +-- +-- * The state refers to different modes of user interaction, see +-- 'StateType' for more information. +-- +widgetGetState :: WidgetClass self => self -> IO StateType +widgetGetState widget = + liftM (toEnum . fromIntegral) $ + {#call widget_get_state#} + (toWidget widget) +#endif + +-- | This function is for use in widget implementations. Sets the state of a +-- widget (insensitive, prelighted, etc.) Usually you should set the state +-- using wrapper functions such as 'widgetSetSensitive'. +-- +widgetSetState :: WidgetClass self => self -> StateType -> IO () +widgetSetState widget state = + {#call widget_set_state#} + (toWidget widget) + ((fromIntegral . fromEnum) state) + -- | 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 @@ -2286,6 +2314,14 @@ widgetStyle :: WidgetClass self => Attr self Style widgetStyle = newAttrFromObjectProperty "style" gTypeStyle +-- | The current visual user interaction state of the widget (insensitive, +-- prelighted, selected etc). See 'StateType' for more information. +-- +widgetState :: WidgetClass self => Attr self StateType +widgetState = newAttr + widgetGetState + widgetSetState + -- %hash c:e2a4 d:9296 -- | The event mask that decides what kind of GdkEvents this widget gets. -- @@ -2655,17 +2691,27 @@ -- the following flags: -- -- * 'PointerMotionMask': Track all movements. +-- -- * 'ButtonMotionMask': Only track movements if a button is depressed. --- * 'Button1MotionMask': Only track movments if the left button is depressed. --- * 'Button2MotionMask': Only track movments if the middle button is depressed. --- * 'Button3MotionMask': Only track movments if the right button is depressed. -- --- If the application cannot respond quickly enough to all mouse motions, --- it is possible to only receive motion signals on request. In this case, --- you need to add 'PointerMotionHintMask' to the flags above and call --- 'Graphics.UI.Gtk.Gdk.DrawWindow.drawWindowGetPointer' each time a --- motion even is received. Motion events will then be delayed until the --- function is called. +-- * 'Button1MotionMask': Only track movements if the left button is depressed. +-- +-- * 'Button2MotionMask': Only track movements if the middle button is depressed. +-- +-- * 'Button3MotionMask': Only track movements if the right button is depressed. +-- 'PointerMotionHintMask' is a special flag which can be used in +-- combination with any of the above and is used to reduce the number of +-- 'motionNotifyEvent's received. Normally a 'motionNotifyEvent' event is +-- received each time the mouse moves. However, if the application spends a +-- lot of time processing the event (updating the display, for example), it +-- can lag behind the position of the mouse. When using +-- 'PointerMotionHintMask', fewer 'motionNotifyEvent's will be sent, some of +-- which are marked as a hint. To receive more motion events after a motion +-- hint event, the application needs to asks for more, by calling +-- 'Graphics.UI.Gtk.Gdk.EventM.eventRequestMotions'. This effectively limits +-- the rate at which new motion events are received. (Note that you don't +-- need to check if the hint is set as +-- 'Graphics.UI.Gtk.Gdk.EventM.eventRequestMotions' does so automatically.) -- motionNotifyEvent :: WidgetClass self => Signal self (EventM EMotion Bool) motionNotifyEvent = Signal (eventM "motion_notify_event" []) 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 @@ -78,11 +78,13 @@ drawWindowGetPointer, drawWindowGetPointerPos, drawWindowGetOrigin, + drawWindowSetCursor, drawWindowForeignNew, drawWindowGetDefaultRootWindow, ) where import Control.Monad (liftM) +import Data.Maybe (fromMaybe) import System.Glib.FFI import System.Glib.Flags (toFlags) @@ -90,6 +92,7 @@ {#import Graphics.UI.Gtk.Types#} {#import Graphics.UI.Gtk.Gdk.Enums#} {#import Graphics.UI.Gtk.Gdk.Region#} +{#import Graphics.UI.Gtk.Gdk.Cursor#} import Graphics.UI.Gtk.Gdk.EventM (Modifier, eventRegion) import Graphics.UI.Gtk.General.Structs import Graphics.UI.Gtk.Abstract.Widget (widgetSetDoubleBuffered) @@ -550,6 +553,18 @@ y <- peek yPtr return (fromIntegral x, fromIntegral y) +-- | Sets the mouse pointer for a 'DrawWindow'. +-- +-- Use 'cursorNewForDisplay' or 'cursorNewFromPixmap' to create the cursor. +-- To make the cursor invisible, use 'BlankCursor'. Passing @Nothing@ means +-- that the @DrawWindow@ will use the cursor of its parent @DrawWindow@. +-- Most @DrawWindow@ should use this default. +-- +drawWindowSetCursor :: DrawWindow -> Maybe Cursor -> IO () +drawWindowSetCursor self cursor = + {# call gdk_window_set_cursor #} + self + (fromMaybe (Cursor nullForeignPtr) cursor) -- | Get the handle to an exising window of the windowing system. The -- passed-in handle is a reference to a native window, that is, an Xlib XID 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 @@ -135,6 +135,9 @@ ScrollDirection(..), eventScrollDirection, eventIsHint, +#if GTK_CHECK_VERSION(2,12,0) + eventRequestMotions, +#endif eventArea, eventRegion, VisibilityState(..), @@ -503,6 +506,31 @@ eventIsHint :: EventM EMotion Bool eventIsHint = ask >>= \ptr -> liftIO $ liftM toBool (#{peek GdkEventMotion, is_hint} ptr :: IO #{gtk2hs_type gint16}) + +#if GTK_CHECK_VERSION(2,12,0) +-- | Request more motion notifies if this event is a motion notify hint event. +-- +-- This action should be used instead of 'drawWindowGetPointer' to request +-- further motion notifies, because it also works for extension events where +-- motion notifies are provided for devices other than the core pointer. +-- +-- Coordinate extraction, processing and requesting more motion events from a +-- 'motionNotifyEvent' usually works like this: +-- +-- > on widget motionNotifyEvent $ do +-- (x, y) <- eventCoordinates +-- -- handle the x,y motion: +-- ... +-- -- finally, notify that we are ready to get more motion events: +-- eventRequestMotions +-- +eventRequestMotions :: EventM EMotion () +eventRequestMotions = ask >>= \ptr -> liftIO $ + gdk_event_request_motions ptr + +foreign import ccall "gdk_event_request_motions" + gdk_event_request_motions :: Ptr EMotion -> IO () +#endif -- | Query a bounding box of the region that needs to be updated. eventArea :: EventM EExpose Rectangle diff --git a/Graphics/UI/Gtk/Gdk/GC.chs b/Graphics/UI/Gtk/Gdk/GC.chs --- a/Graphics/UI/Gtk/Gdk/GC.chs +++ b/Graphics/UI/Gtk/Gdk/GC.chs @@ -78,11 +78,7 @@ import Control.Monad (when) import Data.Maybe (fromJust, isJust) -#ifdef HAVE_NEW_CONTROL_EXCEPTION -import Control.OldException (handle) -#else -import Control.Exception (handle) -#endif +import Control.Exception (handle, ErrorCall(..)) import System.Glib.FFI import System.Glib.GObject (wrapNewGObject) @@ -110,11 +106,11 @@ mask <- pokeGCValues vPtr gcv gc <- wrapNewGObject mkGC $ {#call unsafe gc_new_with_values#} (toDrawable d) (castPtr vPtr) mask - handle (const $ return ()) $ when (isJust (tile gcv)) $ + handle (\(ErrorCall _) -> return ()) $ when (isJust (tile gcv)) $ touchForeignPtr ((unPixmap.fromJust.tile) gcv) - handle (const $ return ()) $ when (isJust (stipple gcv)) $ + handle (\(ErrorCall _) -> return ()) $ when (isJust (stipple gcv)) $ touchForeignPtr ((unPixmap.fromJust.stipple) gcv) - handle (const $ return ()) $ when (isJust (clipMask gcv)) $ + handle (\(ErrorCall _) -> return ()) $ when (isJust (clipMask gcv)) $ touchForeignPtr ((unPixmap.fromJust.clipMask) gcv) return gc @@ -124,11 +120,11 @@ gcSetValues gc gcv = allocaBytes (sizeOf gcv) $ \vPtr -> do mask <- pokeGCValues vPtr gcv gc <- {#call unsafe gc_set_values#} gc (castPtr vPtr) mask - handle (const $ return ()) $ when (isJust (tile gcv)) $ + handle (\(ErrorCall _) -> return ()) $ when (isJust (tile gcv)) $ touchForeignPtr ((unPixmap.fromJust.tile) gcv) - handle (const $ return ()) $ when (isJust (stipple gcv)) $ + handle (\(ErrorCall _) -> return ()) $ when (isJust (stipple gcv)) $ touchForeignPtr ((unPixmap.fromJust.stipple) gcv) - handle (const $ return ()) $ when (isJust (clipMask gcv)) $ + handle (\(ErrorCall _) -> return ()) $ when (isJust (clipMask gcv)) $ touchForeignPtr ((unPixmap.fromJust.clipMask) gcv) return gc diff --git a/Graphics/UI/Gtk/Gdk/PixbufData.hs b/Graphics/UI/Gtk/Gdk/PixbufData.hs --- a/Graphics/UI/Gtk/Gdk/PixbufData.hs +++ b/Graphics/UI/Gtk/Gdk/PixbufData.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses #-} {-# OPTIONS_HADDOCK hide #-} -- -*-haskell-*- -- GIMP Toolkit (GTK) Pixbuf as Array @@ -38,35 +38,22 @@ import Data.Ix -- internal module of GHC import Data.Array.Base ( MArray, newArray, newArray_, unsafeRead, unsafeWrite, -#if __GLASGOW_HASKELL__ < 605 - HasBounds, bounds -#else - getBounds -#endif -#if __GLASGOW_HASKELL__ >= 608 - ,getNumElements -#endif - ) + getBounds, getNumElements ) -- | An array that stored the raw pixel data of a 'Pixbuf'. -- -- * See 'Graphics.UI.Gtk.Gdk.Pixbuf.pixbufGetPixels'. -- -data Ix i => PixbufData i e = PixbufData !Pixbuf - {-# UNPACK #-} !(Ptr e) - !(i,i) - {-# UNPACK #-} !Int +data PixbufData i e = PixbufData !Pixbuf + {-# UNPACK #-} !(Ptr e) + !(i,i) + {-# UNPACK #-} !Int mkPixbufData :: Storable e => Pixbuf -> Ptr e -> Int -> PixbufData Int e mkPixbufData pb (ptr :: Ptr e) size = PixbufData pb ptr (0, count) count where count = fromIntegral (size `div` sizeOf (undefined :: e)) -#if __GLASGOW_HASKELL__ < 605 -instance HasBounds PixbufData where - bounds (PixbufData pb ptr bd cnt) = bd -#endif - -- | 'PixbufData' is a mutable array. instance Storable e => MArray PixbufData e IO where newArray (l,u) e = error "Gtk.Gdk.Pixbuf.newArray: not implemented" @@ -80,11 +67,7 @@ unsafeWrite (PixbufData (Pixbuf pb) pixPtr _ _) idx elem = do pokeElemOff pixPtr idx elem touchForeignPtr pb -#if __GLASGOW_HASKELL__ >= 605 {-# INLINE getBounds #-} getBounds (PixbufData _ _ bd _) = return bd -#endif -#if __GLASGOW_HASKELL__ >= 608 {-# INLINE getNumElements #-} getNumElements (PixbufData _ _ _ count) = return count -#endif diff --git a/Graphics/UI/Gtk/General/Enums.chs b/Graphics/UI/Gtk/General/Enums.chs --- a/Graphics/UI/Gtk/General/Enums.chs +++ b/Graphics/UI/Gtk/General/Enums.chs @@ -83,7 +83,9 @@ WindowPosition(..), WindowType(..), WrapMode(..), +#if GTK_CHECK_VERSION(2,16,0) EntryIconPosition(..), +#endif AnchorType (..), module Graphics.UI.Gtk.Gdk.Enums @@ -424,9 +426,11 @@ -- {#enum WrapMode {underscoreToCase} deriving (Eq,Show)#} +#if GTK_CHECK_VERSION(2,16,0) -- | Specifies the side of the entry at which an icon is placed. -- {#enum EntryIconPosition {underscoreToCase} deriving (Eq,Show)#} +#endif -- | -- 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances #-} {-# OPTIONS_HADDOCK hide #-} -- -*-haskell-*- @@ -106,11 +106,7 @@ import Control.Monad (liftM) import Data.IORef -#ifdef HAVE_NEW_CONTROL_EXCEPTION -import Control.OldException -#else -import Control.Exception -#endif +import Control.Exception (handle, ErrorCall(..)) import System.Glib.FFI import System.Glib.UTFString ( UTFCorrection, ofsToUTF ) @@ -595,12 +591,12 @@ #endif #endif -#if !defined(WIN32) -foreign import ccall unsafe "gdk_x11_drawable_get_xid" - gdk_x11_drawable_get_xid :: (Ptr Drawable) -> IO CInt -#else +#if defined(WIN32) foreign import ccall unsafe "gdk_win32_drawable_get_handle" gdk_win32_drawable_get_handle :: (Ptr Drawable) -> IO (Ptr a) +#elif !defined(HAVE_QUARTZ_GTK) +foreign import ccall unsafe "gdk_x11_drawable_get_xid" + gdk_x11_drawable_get_xid :: (Ptr Drawable) -> IO CInt #endif -- | Get 'NativeWindowId' of 'Drawable'. @@ -608,10 +604,12 @@ drawableGetID d = liftM toNativeWindowId $ (\(Drawable drawable) -> -#if !defined(WIN32) - withForeignPtr drawable gdk_x11_drawable_get_xid -#else +#if defined(WIN32) withForeignPtr drawable gdk_win32_drawable_get_handle +#elif !defined(HAVE_QUARTZ_GTK) + withForeignPtr drawable gdk_x11_drawable_get_xid +#else + error "drawableGetID: not supported with a GTK using a Quartz backend" #endif ) (toDrawable d) diff --git a/Graphics/UI/Gtk/General/Style.chs b/Graphics/UI/Gtk/General/Style.chs --- a/Graphics/UI/Gtk/General/Style.chs +++ b/Graphics/UI/Gtk/General/Style.chs @@ -59,10 +59,20 @@ styleGetDark, styleGetText, styleGetBase, - styleGetAntiAliasing + styleGetAntiAliasing, + + stylePaintFlatBox, + stylePaintLayout, + ) where +{# context prefix ="gtk" #} + +import System.Glib.FFI + {#import Graphics.UI.Gtk.Types#} +{#import Graphics.Rendering.Pango.Types#} +import Graphics.Rendering.Pango.BasicTypes import Graphics.UI.Gtk.General.Structs (styleGetForeground, styleGetBackground, styleGetLight, @@ -70,5 +80,57 @@ styleGetDark, styleGetText, styleGetBase, - styleGetAntiAliasing) + styleGetAntiAliasing, + Rectangle) +import Graphics.UI.Gtk.General.Enums (StateType, ShadowType) +stylePaintFlatBox :: WidgetClass widget + => Style + -> DrawWindow + -> StateType + -> ShadowType + -> Rectangle + -> widget + -> String + -> Int -> Int -> Int -> Int + -> IO () +stylePaintFlatBox style window stateType shadowType + clipRect widget detail x y width height = + with clipRect $ \rectPtr -> + withCString detail $ \detailPtr -> + {# call paint_flat_box #} + style + window + ((fromIntegral.fromEnum) stateType) + ((fromIntegral.fromEnum) shadowType) + (castPtr rectPtr) + (toWidget widget) + detailPtr + (fromIntegral x) (fromIntegral y) + (fromIntegral width) (fromIntegral height) + +stylePaintLayout :: WidgetClass widget + => Style + -> DrawWindow + -> StateType + -> Bool + -> Rectangle + -> widget + -> String + -> Int -> Int + -> PangoLayout + -> IO () +stylePaintLayout style window stateType useText + clipRect widget detail x y (PangoLayout _ layout) = + with clipRect $ \rectPtr -> + withCString detail $ \detailPtr -> + {# call gtk_paint_layout #} + style + window + ((fromIntegral.fromEnum) stateType) + (fromBool useText) + (castPtr rectPtr) + (toWidget widget) + detailPtr + (fromIntegral x) (fromIntegral y) + layout diff --git a/Graphics/UI/Gtk/ModelView/ListStore.hs b/Graphics/UI/Gtk/ModelView/ListStore.hs --- a/Graphics/UI/Gtk/ModelView/ListStore.hs +++ b/Graphics/UI/Gtk/ModelView/ListStore.hs @@ -180,7 +180,8 @@ listStoreSetValue :: ListStore a -> Int -> a -> IO () listStoreSetValue (ListStore model) index value = do modifyIORef (customStoreGetPrivate model) (Seq.update index value) - treeModelRowChanged model [index] (TreeIter 0 (fromIntegral index) 0 0) + stamp <- customStoreGetStamp model + treeModelRowChanged model [index] (TreeIter stamp (fromIntegral index) 0 0) -- | Extract all data from the store. -- diff --git a/Graphics/UI/Gtk/ModelView/TreeView.chs b/Graphics/UI/Gtk/ModelView/TreeView.chs --- a/Graphics/UI/Gtk/ModelView/TreeView.chs +++ b/Graphics/UI/Gtk/ModelView/TreeView.chs @@ -185,6 +185,12 @@ treeViewSetGridLines, #endif #endif +#if GTK_CHECK_VERSION(2,12,0) + treeViewSetTooltipRow, + treeViewSetTooltipCell, + treeViewGetTooltipContext, +#endif + -- * Attributes treeViewModel, treeViewHAdjustment, @@ -214,6 +220,9 @@ treeViewGridLines, treeViewSearchEntry, #endif +#if GTK_CHECK_VERSION(2,12,0) + treeViewTooltipColumn, +#endif -- * Signals columnsChanged, @@ -223,7 +232,7 @@ rowActivated, testCollapseRow, testExpandRow, - + -- * Deprecated #ifndef DISABLE_DEPRECATED treeViewWidgetToTreeCoords, @@ -1543,6 +1552,62 @@ #endif #endif +#if GTK_CHECK_VERSION(2,12,0) +-- | Sets the tip area of @tooltip@ to be the area covered by @path@. See also +-- 'treeViewTooltipColumn' for a simpler alternative. See also +-- 'tooltipSetTipArea'. +treeViewSetTooltipRow :: TreeViewClass self => self + -> Tooltip -- ^ the @tooltip@ + -> TreePath -- ^ @path@ - the position of the @tooltip@ + -> IO () +treeViewSetTooltipRow self tip path = + withTreePath path $ \path -> + {#call gtk_tree_view_set_tooltip_row #} (toTreeView self) tip path + +-- | Sets the tip area of tooltip to the area path, column and cell have in +-- common. For example if @path@ is @Nothing@ and @column@ is set, the tip area will be +-- set to the full area covered by column. See also +-- 'tooltipSetTipArea'. Note that if @path@ is not specified and @cell@ is +-- set and part of a column containing the expander, the tooltip might not +-- show and hide at the correct position. In such cases @path@ must be set to +-- the current node under the mouse cursor for this function to operate +-- correctly. See also 'treeViewTooltipColumn' for a simpler alternative. +-- +treeViewSetTooltipCell :: (TreeViewClass self, TreeViewColumnClass col, + CellRendererClass renderer) => self + -> Tooltip -- ^ the @tooltip@ + -> Maybe TreePath -- ^ @path@ at which the tip should be shown + -> Maybe col -- ^ @column@ at which the tip should be shown + -> Maybe renderer -- ^ the @renderer@ for which to show the tip + -> IO () +treeViewSetTooltipCell self tip mPath mColumn mRenderer = + (case mPath of Just path -> withTreePath path + Nothing -> \f -> f (NativeTreePath nullPtr)) $ \path -> do + {#call gtk_tree_view_set_tooltip_cell#} (toTreeView self) tip path + (maybe (TreeViewColumn nullForeignPtr) toTreeViewColumn mColumn) + (maybe (CellRenderer nullForeignPtr) toCellRenderer mRenderer) + +-- | This function is supposed to be used in a 'widgetQueryTooltip' signal handler +-- for this 'TreeView'. The @point@ value which is received in the +-- signal handler should be passed to this function without modification. A +-- return value of @Just iter@ indicates that there is a tree view row at the given +-- coordinates (if @Just (x,y)@ is passed in, denoting a mouse position), resp. +-- the cursor row (if @Nothing@ is passed in, denoting a keyboard request). +-- +treeViewGetTooltipContext :: TreeViewClass self => self + -> Maybe Point -- ^ @point@ - the coordinates of the mouse or @Nothing@ + -- if a keyboard tooltip is to be generated + -> IO (Maybe TreeIter) -- ^ @Just iter@ if a tooltip should be shown for that row +treeViewGetTooltipContext self (Just (x,y)) = + alloca $ \xPtr -> alloca $ \yPtr -> receiveTreeIter $ + {#call gtk_tree_view_get_tooltip_context#} (toTreeView self) + xPtr yPtr 0 nullPtr nullPtr +treeViewGetTooltipContext self Nothing = + receiveTreeIter $ + {#call gtk_tree_view_get_tooltip_context#} (toTreeView self) + nullPtr nullPtr 1 nullPtr nullPtr +#endif + -------------------- -- Attributes @@ -1620,9 +1685,7 @@ -- %hash c:e732 -- | Model column to search through when searching through code. -- --- Allowed values: >= -1 --- --- Default value: -1 +-- Default value: 'invalidColumnId' -- treeViewSearchColumn :: TreeViewClass self => Attr self (ColumnId row String) treeViewSearchColumn = newAttr @@ -1739,6 +1802,34 @@ treeViewSearchEntry = newAttr treeViewGetSearchEntry treeViewSetSearchEntry +#endif + +#if GTK_CHECK_VERSION(2,12,0) +-- | The column for which to show tooltips. +-- +-- If you only plan to have simple (text-only) tooltips on full rows, you can +-- use this function to have 'TreeView' handle these automatically for you. +-- @column@ should be set to a column in model containing the tooltip texts, +-- or @-1@ to disable this feature. When enabled, 'widgetHasTooltip' will be +-- set to @True@ and this view will connect to the 'widgetQueryTooltip' signal +-- handler. +-- +-- Note that the signal handler sets the text as 'Markup', +-- so \&, \<, etc have to be escaped in the text. +-- +-- Default value: 'invalidColumnId' +-- +treeViewTooltipColumn :: TreeViewClass self => Attr self (ColumnId row String) +treeViewTooltipColumn = newAttr + (\self -> liftM (makeColumnIdString . fromIntegral) $ + {# call unsafe tree_view_get_tooltip_column #} + (toTreeView self) + ) + (\self column -> + {# call tree_view_set_tooltip_column #} + (toTreeView self) + (fromIntegral (columnIdToNumber column)) + ) #endif -------------------- diff --git a/Gtk2HsSetup.hs b/Gtk2HsSetup.hs --- a/Gtk2HsSetup.hs +++ b/Gtk2HsSetup.hs @@ -1,37 +1,7 @@ {-# LANGUAGE CPP #-} -#define CABAL_VERSION_ENCODE(major, minor, micro) ( \ - ((major) * 10000) \ - + ((minor) * 100) \ - + ((micro) * 1)) - -#define CABAL_VERSION_CHECK(major,minor,micro) \ - (CABAL_VERSION >= CABAL_VERSION_ENCODE(major,minor,micro)) - --- now, this is bad, but Cabal doesn't seem to actually pass any information about --- its version to CPP, so guess the version depending on the version of GHC -#ifdef CABAL_VERSION_MINOR -#ifndef CABAL_VERSION_MAJOR -#define CABAL_VERSION_MAJOR 1 -#endif -#ifndef CABAL_VERSION_MICRO -#define CABAL_VERSION_MICRO 0 -#endif -#define CABAL_VERSION CABAL_VERSION_ENCODE( \ - CABAL_VERSION_MAJOR, \ - CABAL_VERSION_MINOR, \ - CABAL_VERSION_MICRO) -#else -#warning Setup.hs is guessing the version of Cabal. If compilation of Setup.hs fails use -DCABAL_VERSION_MINOR=x for Cabal version 1.x.0 when building (prefixed by --ghc-option= when using the 'cabal' command) -#if (__GLASGOW_HASKELL__ >= 700) -#define CABAL_VERSION CABAL_VERSION_ENCODE(1,10,0) -#else -#if (__GLASGOW_HASKELL__ >= 612) -#define CABAL_VERSION CABAL_VERSION_ENCODE(1,8,0) -#else -#define CABAL_VERSION CABAL_VERSION_ENCODE(1,6,0) -#endif -#endif +#ifndef CABAL_VERSION_CHECK +#error This module has to be compiled via the Setup.hs program which generates the gtk2hs-macros.h file #endif -- | Build a Gtk2hs package. @@ -49,13 +19,7 @@ libraryDirs, extraLibraries, extraGHCiLibraries ) -import Distribution.Simple.PackageIndex ( -#if CABAL_VERSION_CHECK(1,8,0) - lookupInstalledPackageId -#else - lookupPackageId -#endif - ) +import Distribution.Simple.PackageIndex ( lookupInstalledPackageId ) import Distribution.PackageDescription as PD ( PackageDescription(..), updatePackageDescription, BuildInfo(..), @@ -64,17 +28,13 @@ libModules, hasLibs) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..), InstallDirs(..), -#if CABAL_VERSION_CHECK(1,8,0) componentPackageDeps, -#else - packageDeps, -#endif absoluteInstallDirs) import Distribution.Simple.Compiler ( Compiler(..) ) import Distribution.Simple.Program ( Program(..), ConfiguredProgram(..), - rawSystemProgramConf, rawSystemProgramStdoutConf, programName, - c2hsProgram, pkgConfigProgram, requireProgram, ghcPkgProgram, + rawSystemProgramConf, rawSystemProgramStdoutConf, programName, programPath, + c2hsProgram, pkgConfigProgram, gccProgram, requireProgram, ghcPkgProgram, simpleProgram, lookupProgram, rawSystemProgramStdout, ProgArg) import Distribution.ModuleName ( ModuleName, components, toFilePath ) import Distribution.Simple.Utils @@ -84,11 +44,7 @@ fromFlagOrDefault, defaultRegisterFlags) import Distribution.Simple.BuildPaths ( autogenModulesDir ) import Distribution.Simple.Install ( install ) -#if CABAL_VERSION_CHECK(1,8,0) import Distribution.Simple.Register ( generateRegistrationInfo, registerPackage ) -#else -import qualified Distribution.Simple.Register as Register ( register ) -#endif import Distribution.Text ( simpleParse, display ) import System.FilePath import System.Exit (exitFailure) @@ -147,8 +103,6 @@ -- The following code is a big copy-and-paste job from the sources of -- Cabal 1.8 just to be able to fix a field in the package file. Yuck. -#if CABAL_VERSION_CHECK(1,8,0) - installHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () installHook pkg_descr localbuildinfo _ flags = do @@ -195,19 +149,20 @@ _ | modeGenerateRegFile -> die "Generate Reg File not supported" | modeGenerateRegScript -> die "Generate Reg Script not supported" | otherwise -> registerPackage verbosity + installedPkgInfo pkg lbi inplace #if CABAL_VERSION_CHECK(1,10,0) - installedPkgInfo pkg lbi inplace [packageDb] + packageDbs #else - installedPkgInfo pkg lbi inplace packageDb + packageDb #endif where modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) modeGenerateRegScript = fromFlag (regGenScript regFlags) inplace = fromFlag (regInPlace regFlags) - packageDb = case flagToMaybe (regPackageDB regFlags) of - Just db -> db - Nothing -> registrationPackageDB (withPackageDB lbi) + packageDbs = nub $ withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) + packageDb = registrationPackageDB packageDbs distPref = fromFlag (regDistPref regFlags) verbosity = fromFlag (regVerbosity regFlags) @@ -215,45 +170,7 @@ where verbosity = fromFlag (regVerbosity regFlags) -#else -installHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> InstallFlags -> IO () -installHook pkg_descr localbuildinfo _ flags = do - let copyFlags = defaultCopyFlags { - copyDistPref = installDistPref flags, - copyInPlace = installInPlace flags, - copyUseWrapper = installUseWrapper flags, - copyDest = toFlag NoCopyDest, - copyVerbosity = installVerbosity flags - } - install pkg_descr localbuildinfo copyFlags - let registerFlags = defaultRegisterFlags { - regDistPref = installDistPref flags, - regInPlace = installInPlace flags, - regPackageDB = installPackageDB flags, - regVerbosity = installVerbosity flags - } - when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags -registerHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> RegisterFlags -> IO () -registerHook pkg_descr localbuildinfo _ flags = - if hasLibs pkg_descr - then register pkg_descr localbuildinfo flags - else setupMessage verbosity - "Package contains no library to register:" (packageId pkg_descr) - where verbosity = fromFlag (regVerbosity flags) - -register :: PackageDescription -> LocalBuildInfo - -> RegisterFlags -- ^Install in the user's database?; verbose - -> IO () -register pkg_descr lbi regFlags = do - let verbosity = fromFlag (regVerbosity regFlags) - warn verbosity "Cannot register ghci libraries with Cabal 1.6 (need 1.8)." - Register.register pkg_descr lbi regFlags - -#endif - ------------------------------------------------------------------------------ -- This is a hack for Cabal-1.8, It is not needed in Cabal-1.9.1 or later ------------------------------------------------------------------------------ @@ -291,15 +208,12 @@ -- additional .chi files might be needed that other packages have installed; -- we assume that these are installed in the same place as .hi files let chiDirs = [ dir | -#if CABAL_VERSION_CHECK(1,8,0) ipi <- maybe [] (map fst . componentPackageDeps) (libraryConfig lbi), dir <- maybe [] importDirs (lookupInstalledPackageId (installedPkgs lbi) ipi) ] -#else - ipi <- packageDeps lbi, - dir <- maybe [] importDirs (lookupPackageId (installedPkgs lbi) ipi) ] -#endif + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) rawSystemProgramConf verbosity c2hsLocal (withPrograms lbi) $ map ("--include=" ++) (outDir:chiDirs) + ++ [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi] ++ ["--output-dir=" ++ newOutDir, "--output=" ++ newOutFile, @@ -321,18 +235,10 @@ -- cannot use the recommended 'findModuleFiles' since it fails if there exists -- a modules that does not have a .chi file mFiles <- mapM (findFileWithExtension' ["chi"] [buildDir lbi] . toFilePath) -#if CABAL_VERSION_CHECK(1,8,0) (PD.libModules lib) -#else - (PD.libModules pkg) -#endif let files = [ f | Just f <- mFiles ] -#if CABAL_VERSION_CHECK(1,8,0) installOrdinaryFiles verbosity libPref files -#else - copyFiles verbosity libPref files -#endif installCHI _ _ _ _ = return () @@ -348,7 +254,15 @@ signalGenProgram = simpleProgram "gtk2hsHookGenerator" c2hsLocal :: Program -c2hsLocal = simpleProgram "gtk2hsC2hs" +c2hsLocal = (simpleProgram "gtk2hsC2hs") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "gtk2hsC2hs --version" gives a string like: + -- C->Haskell Compiler, version 0.13.4 (gtk2hs branch) "Bin IO", 13 Nov 2004 + case words str of + (_:_:_:ver:_) -> ver + _ -> "" + } + genSynthezisedFiles :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () genSynthezisedFiles verb pd lbi = do diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,10 +1,10 @@ --- Setup file for a Gtk2Hs module. Contains only adjustments specific to this module, --- all Gtk2Hs-specific boilerplate is stored in Gtk2HsSetup.hs which should be kept --- identical across all modules. -import Gtk2HsSetup ( gtk2hsUserHooks, checkGtk2hsBuildtools ) -import Distribution.Simple ( defaultMainWithHooks ) +-- Standard setup file for a Gtk2Hs module. +-- +-- See also: +-- * SetupMain.hs : the real Setup script for this package +-- * Gtk2HsSetup.hs : Gtk2Hs-specific boilerplate +-- * SetupWrapper.hs : wrapper for compat with various ghc/cabal versions -main = do - checkGtk2hsBuildtools ["gtk2hsC2hs", "gtk2hsTypeGen", "gtk2hsHookGenerator"] - defaultMainWithHooks gtk2hsUserHooks - +import SetupWrapper ( setupWrapper ) + +main = setupWrapper "SetupMain.hs" diff --git a/SetupMain.hs b/SetupMain.hs new file mode 100644 --- /dev/null +++ b/SetupMain.hs @@ -0,0 +1,12 @@ +-- The real Setup file for a Gtk2Hs package (invoked via the SetupWrapper). +-- It contains only adjustments specific to this package, +-- all Gtk2Hs-specific boilerplate is kept in Gtk2HsSetup.hs +-- which should be kept identical across all packages. +-- +import Gtk2HsSetup ( gtk2hsUserHooks, checkGtk2hsBuildtools ) +import Distribution.Simple ( defaultMainWithHooks ) + +main = do + checkGtk2hsBuildtools ["gtk2hsC2hs", "gtk2hsTypeGen", "gtk2hsHookGenerator"] + defaultMainWithHooks gtk2hsUserHooks + diff --git a/SetupWrapper.hs b/SetupWrapper.hs new file mode 100644 --- /dev/null +++ b/SetupWrapper.hs @@ -0,0 +1,155 @@ +-- A wrapper script for Cabal Setup.hs scripts. Allows compiling the real Setup +-- conditionally depending on the Cabal version. + +module SetupWrapper (setupWrapper) where + +import Distribution.Package +import Distribution.Compiler +import Distribution.Simple.Utils +import Distribution.Simple.Program +import Distribution.Simple.Compiler +import Distribution.Simple.BuildPaths (exeExtension) +import Distribution.Simple.Configure (configCompiler) +import Distribution.Simple.GHC (getInstalledPackages) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Version +import Distribution.Verbosity +import Distribution.Text + +import System.Environment +import System.Process +import System.Exit +import System.FilePath +import System.Directory +import qualified Control.Exception as Exception +import System.IO.Error (isDoesNotExistError) + +import Data.List +import Data.Char +import Control.Monad + + +setupWrapper :: FilePath -> IO () +setupWrapper setupHsFile = do + args <- getArgs + createDirectoryIfMissingVerbose verbosity True setupDir + compileSetupExecutable + invokeSetupScript args + + where + setupDir = "dist/setup-wrapper" + setupVersionFile = setupDir "setup" <.> "version" + setupProgFile = setupDir "setup" <.> exeExtension + setupMacroFile = setupDir "wrapper-macros.h" + + useCabalVersion = Version [1,8] [] + usePackageDB = [GlobalPackageDB, UserPackageDB] + verbosity = normal + + cabalLibVersionToUse comp conf = do + savedVersion <- savedCabalVersion + case savedVersion of + Just version + -> return version + _ -> do version <- installedCabalVersion comp conf + writeFile setupVersionFile (show version ++ "\n") + return version + + savedCabalVersion = do + versionString <- readFile setupVersionFile + `Exception.catch` \e -> if isDoesNotExistError e + then return "" + else Exception.throwIO e + case reads versionString of + [(version,s)] | all isSpace s -> return (Just version) + _ -> return Nothing + + installedCabalVersion comp conf = do + index <- getInstalledPackages verbosity usePackageDB conf + + let cabalDep = Dependency (PackageName "Cabal") + (orLaterVersion useCabalVersion) + case PackageIndex.lookupDependency index cabalDep of + [] -> die $ "The package requires Cabal library version " + ++ display useCabalVersion + ++ " but no suitable version is installed." + pkgs -> return $ bestVersion (map fst pkgs) + where + bestVersion = maximumBy (comparing preference) + preference version = (sameVersion, sameMajorVersion + ,stableVersion, latestVersion) + where + sameVersion = version == cabalVersion + sameMajorVersion = majorVersion version == majorVersion cabalVersion + majorVersion = take 2 . versionBranch + stableVersion = case versionBranch version of + (_:x:_) -> even x + _ -> False + latestVersion = version + + -- | If the Setup.hs is out of date wrt the executable then recompile it. + -- Currently this is GHC only. It should really be generalised. + -- + compileSetupExecutable = do + setupHsNewer <- setupHsFile `moreRecentFile` setupProgFile + cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile + let outOfDate = setupHsNewer || cabalVersionNewer + when outOfDate $ do + debug verbosity "Setup script is out of date, compiling..." + + (comp, conf) <- configCompiler (Just GHC) Nothing Nothing + defaultProgramConfiguration verbosity + cabalLibVersion <- cabalLibVersionToUse comp conf + let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion + debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion + + writeFile setupMacroFile (generateVersionMacro cabalLibVersion) + + rawSystemProgramConf verbosity ghcProgram conf $ + ["--make", setupHsFile, "-o", setupProgFile] + ++ ghcPackageDbOptions usePackageDB + ++ ["-package", display cabalPkgid + ,"-cpp", "-optP-include", "-optP" ++ setupMacroFile + ,"-odir", setupDir, "-hidir", setupDir] + where + + ghcPackageDbOptions dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> "-no-user-package-conf" + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ "-package-conf", db ] + specific _ = ierror + ierror = error "internal error: unexpected package db stack" + + generateVersionMacro :: Version -> String + generateVersionMacro version = + concat + ["/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" + ,"#define CABAL_VERSION_CHECK(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + where + (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) + + invokeSetupScript :: [String] -> IO () + invokeSetupScript args = do + info verbosity $ unwords (setupProgFile : args) + process <- runProcess (currentDir setupProgFile) args + Nothing Nothing + Nothing Nothing Nothing + exitCode <- waitForProcess process + unless (exitCode == ExitSuccess) $ exitWith exitCode + +moreRecentFile :: FilePath -> FilePath -> IO Bool +moreRecentFile a b = do + exists <- doesFileExist b + if not exists + then return True + else do tb <- getModificationTime b + ta <- getModificationTime a + return (ta > tb) diff --git a/demo/statusicon/StatusIcon.hs b/demo/statusicon/StatusIcon.hs --- a/demo/statusicon/StatusIcon.hs +++ b/demo/statusicon/StatusIcon.hs @@ -1,19 +1,17 @@ -- 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 + on icon statusIconPopupMenu $ \b a -> do widgetShowAll menu print (b,a) menuPopup menu $ maybe Nothing (\b' -> Just (b',a)) b - I.onActivate icon $ do + on icon statusIconActivate $ do putStrLn "'activate' signal triggered" mainGUI @@ -27,4 +25,4 @@ mkitem menu (label,act) = do i <- menuItemNewWithLabel label menuShellAppend menu i - i `onActivateLeaf` act + on i menuItemActivate act diff --git a/gtk.cabal b/gtk.cabal --- a/gtk.cabal +++ b/gtk.cabal @@ -1,26 +1,26 @@ Name: gtk -Version: 0.12.0 +Version: 0.12.1 License: LGPL-2.1 License-file: COPYING Copyright: (c) 2001-2010 The Gtk2Hs Team Author: Axel Simon, Duncan Coutts and many others -Maintainer: gtk2hs-users@sourceforge.net +Maintainer: gtk2hs-users@lists.sourceforge.net Build-Type: Custom -Cabal-Version: >= 1.6.0 +Cabal-Version: >= 1.8 Stability: provisional -homepage: http://www.haskell.org/gtk2hs/ +homepage: http://projects.haskell.org/gtk2hs/ bug-reports: http://hackage.haskell.org/trac/gtk2hs/ Synopsis: Binding to the Gtk+ graphical user interface library. Description: This is the core library of the Gtk2Hs suite of libraries for Haskell based on Gtk+. Gtk+ is an extensive and mature multi-platform toolkit for creating graphical user interfaces. Category: Graphics -Tested-With: GHC == 6.10.4 +Tested-With: GHC == 6.10.4, GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1 Extra-Source-Files: wingtk.h Graphics/UI/Gtk/ModelView/Gtk2HsStore.h Graphics/UI/Gtk/General/hsgthread.h template-hsc-gtk2hs.h - Gtk2HsSetup.hs + SetupWrapper.hs SetupMain.hs Gtk2HsSetup.hs marshal.list hierarchy.list @@ -124,17 +124,24 @@ Description: Depend on GIO package, thereby enabling certain features. Default: True +Flag have-quartz-gtk + Description: Assume that the installed GTK is the version for OS X backend by Quartz, and hence does not provide gdk_x11_drawable_get_xid + Default: False + Library build-depends: base >= 4 && < 5, - array, containers, haskell98, mtl, bytestring, + array, containers, mtl, bytestring, glib >= 0.12.0 && < 0.13, pango >= 0.12.0 && < 0.13, cairo >= 0.12.0 && < 0.13 if flag(have-gio) build-depends: gio >= 0.12.0 && < 0.13 cpp-options: -DHAVE_GIO + if flag(have-quartz-gtk) + cpp-options: -DHAVE_QUARTZ_GTK - build-tools: gtk2hsC2hs, gtk2hsHookGenerator, gtk2hsTypeGen + build-tools: gtk2hsC2hs >= 0.13.5, + gtk2hsHookGenerator, gtk2hsTypeGen exposed-modules: Graphics.UI.Gtk @@ -363,7 +370,6 @@ -- needs to be imported from this module: x-Signals-Import: Graphics.UI.Gtk.General.Threading include-dirs: . - cpp-options: -DHAVE_NEW_CONTROL_EXCEPTION if !flag(deprecated) cpp-options: -DDISABLE_DEPRECATED else