sifflet-0.1.5: GtkForeign.hs

{-# LANGUAGE ForeignFunctionInterface, CPP #-}
{-# INCLUDE /usr/include/gtk-2.0/gtk/gtk.h #-}
{-# INCLUDE /usr/include/gtk-2.0/gdk/gdk.h #-}

-- NOTE: START GHCI AS FOLLOWS:
-- ghci -lgtk-x11-2.0 -lgdk-x11-2.0
-- ================================

-- File: GtkForeign.hs
-- Foreign functions from Gtk

-- CURSOR SHAPES
-- Original source: https://sourceforge.net/mailarchive/forum.php?thread_name=87ps50ie9o.fsf%40loki.cmears.id.au&forum_name=gtk2hs-users
-- Copyright status ??????

{-  	
Re: [Gtk2hs-users] Changing the mouse cursor shape
From: Chris Mears <chris@cm...> - 2007-05-22 07:48
Hi Axel,

Axel Simon <A.Simon@ke...> writes:

> We haven't done that yet.
> The functions required are a few in Gdk for creating cursors and looking
> up stock cursors. Also, in Gdk.DrawWindow the function
> gdk_window_set_cursor would need to be bound. If changing cursors would
> be useful for your application, then I can add these functions into the
> next minor release which Duncan wants to do soon.

Thanks for the information. With your pointers, I was able to hack up
the following code to suit my needs:

data Cursor = Cursor
type CursorPtr = Ptr Cursor
foreign import ccall "gdk_window_set_cursor" gdkWindowSetCursor :: Ptr DrawWindow -> CursorPtr -> IO ()
foreign import ccall "gdk_cursor_new" gdkCursorNew :: Int -> IO CursorPtr
setCursor :: Window -> IO ()
setCursor window = do
c <- gdkCursorNew 34 -- the 'crosshair' cursor
d <- widgetGetDrawWindow window
withForeignPtr (unDrawWindow d) $ \ptr -> gdkWindowSetCursor ptr c

I tried briefly to add some of the bindings to the library, but I don't
understand the build system or the library design well enough to do it
properly. I can confirm that adding the cursor bindings is not very
hard. If you could add them, that would be great, but you needn't do it
solely on my account.

Chris
-}

-- Gtk2hs has added a definition of CursorType in version 0.10.1,
-- but in version 0.10.0 and lower, we have to do it ourselves.

#if MIN_VERSION_gtk(0,10,1)
#define GTK_HAS_CURSOR_TYPE 1
#else
#define GTK_HAS_CURSOR_TYPE 0
#endif

module GtkForeign 
    (
#if GTK_HAS_CURSOR_TYPE
     Graphics.UI.Gtk.CursorType(..)
#else
     CursorType(..)
#endif
    , setCursor)
where

import System.Glib
import System.Glib.FFI
import Foreign.ForeignPtr (castForeignPtr)
import Graphics.UI.Gtk

-- type CursorPtr = Ptr Cursor

foreign import ccall "gdk_window_set_cursor" gdkWindowSetCursor :: 
    Ptr DrawWindow -> Ptr Cursor -> IO ()

foreign import ccall "gdk_cursor_new" gdkCursorNew :: Int -> IO (Ptr Cursor)

-- | Set the X Window cursor for a window to a specified type
setCursor :: Window -> CursorType -> IO ()
setCursor window cursorType = do
  c <- gdkCursorNew (cursorTypeNumber cursorType)
  d <- widgetGetDrawWindow window
  let GObject fp = toGObject d
  withForeignPtr (castForeignPtr fp) $ \ptr -> gdkWindowSetCursor ptr c

#if ! GTK_HAS_CURSOR_TYPE
-- Cursor types are added to gtk2hs in v. 0.10.1, but we need this for
-- earlier versions including 0.10.0.
-- For illustrations, see
-- http://www.pygtk.org/docs/pygtk/class-gdkcursor.html

data CursorType = XCursor 
                | Arrow
                | BasedArrowDown
                | BasedArrowUp
                | Boat
                | Bogosity
                | BottomLeftCorner
                | BottomRightCorner
                | BottomSide
                | BottomTee
                | BoxSpiral
                | CenterPtr
                | Circle
                | Clock
                | CoffeeMug
                | Cross
                | CrossReverse
                | Crosshair
                | DiamondCross
                | Dot
                | Dotbox
                | DoubleArrow
                | DraftLarge
                | DraftSmall
                | DrapedBox
                | Exchange
                | Fleur
                | Gobbler
                | Gumby
                | Hand1
                | Hand2
                | Heart
                | Icon
                | IronCross
                | LeftPtr
                | LeftSide
                | LeftTee
                | Leftbutton
                | LlAngle
                | LrAngle
                | Man
                | Middlebutton
                | Mouse
                | Pencil
                | Pirate
                | Plus
                | QuestionArrow
                | RightPtr
                | RightSide
                | RightTee
                | Rightbutton
                | RtlLogo
                | Sailboat
                | SbDownArrow
                | SbHDoubleArrow
                | SbLeftArrow
                | SbRightArrow
                | SbUpArrow
                | SbVDoubleArrow
                | Shuttle
                | Sizing
                | Spider
                | Spraycan
                | Star
                | Target
                | Tcross
                | TopLeftArrow
                | TopLeftCorner
                | TopRightCorner
                | TopSide
                | TopTee
                | Trek
                | UlAngle
                | Umbrella
                | UrAngle
                | Watch
                | Xterm
                | LastCursor
                | CursorIsPixmap
                  deriving (Eq, Read, Show)
#endif

cursorTypeNumber :: CursorType -> Int
cursorTypeNumber cursorType =
    case cursorType of
      XCursor -> 0
      Arrow -> 2
      BasedArrowDown -> 4
      BasedArrowUp -> 6
      Boat -> 8
      Bogosity -> 10
      BottomLeftCorner -> 12
      BottomRightCorner -> 14
      BottomSide -> 16
      BottomTee -> 18
      BoxSpiral -> 20
      CenterPtr -> 22
      Circle -> 24
      Clock -> 26
      CoffeeMug -> 28
      Cross -> 30
      CrossReverse -> 32
      Crosshair -> 34
      DiamondCross -> 36
      Dot -> 38
      Dotbox -> 40
      DoubleArrow -> 42
      DraftLarge -> 44
      DraftSmall -> 46
      DrapedBox -> 48
      Exchange -> 50
      Fleur -> 52
      Gobbler -> 54
      Gumby -> 56
      Hand1 -> 58
      Hand2 -> 60
      Heart -> 62
      Icon -> 64
      IronCross -> 66
      LeftPtr -> 68
      LeftSide -> 70
      LeftTee -> 72
      Leftbutton -> 74
      LlAngle -> 76
      LrAngle -> 78
      Man -> 80
      Middlebutton -> 82
      Mouse -> 84
      Pencil -> 86
      Pirate -> 88
      Plus -> 90
      QuestionArrow -> 92
      RightPtr -> 94
      RightSide -> 96
      RightTee -> 98
      Rightbutton -> 100
      RtlLogo -> 102
      Sailboat -> 104
      SbDownArrow -> 106
      SbHDoubleArrow -> 108
      SbLeftArrow -> 110
      SbRightArrow -> 112
      SbUpArrow -> 114
      SbVDoubleArrow -> 116
      Shuttle -> 118
      Sizing -> 120
      Spider -> 122
      Spraycan -> 124
      Star -> 126
      Target -> 128
      Tcross -> 130
      TopLeftArrow -> 132
      TopLeftCorner -> 134
      TopRightCorner -> 136
      TopSide -> 138
      TopTee -> 140
      Trek -> 142
      UlAngle -> 144
      Umbrella -> 146
      UrAngle -> 148
      Watch -> 150
      Xterm -> 152
      LastCursor -> (-1)
      CursorIsPixmap -> (-1)