diff --git a/GLFW-b.cabal b/GLFW-b.cabal --- a/GLFW-b.cabal +++ b/GLFW-b.cabal @@ -1,5 +1,5 @@ name: GLFW-b -version: 1.4.7.3 +version: 1.4.8.0 category: Graphics author: Brian Lewis @@ -50,7 +50,7 @@ build-depends: base < 5, - bindings-GLFW >= 3.1.1.4 + bindings-GLFW >= 3.1.2.0 -------------------------------------------------------------------------------- @@ -68,7 +68,7 @@ GLFW-b, HUnit == 1.2.*, base < 5, - bindings-GLFW >= 3.1.1.4, + bindings-GLFW >= 3.1.2.0, test-framework == 0.8.*, test-framework-hunit == 0.3.* diff --git a/Graphics/UI/GLFW.hs b/Graphics/UI/GLFW.hs --- a/Graphics/UI/GLFW.hs +++ b/Graphics/UI/GLFW.hs @@ -95,6 +95,9 @@ , StickyKeysInputMode (..) , StickyMouseButtonsInputMode (..) , ModifierKeys (..) + , Image (..) + , Cursor (..) + , StandardCursorShape (..) -- -- related to c'glfwSetInputMode ----. , getCursorInputMode -- | @@ -111,7 +114,12 @@ , setMouseButtonCallback, MouseButtonCallback , setCursorPosCallback, CursorPosCallback , setCursorEnterCallback, CursorEnterCallback + , createCursor + , createStandardCursor + , setCursor + , destroyCursor , setScrollCallback, ScrollCallback + , setDropCallback, DropCallback , joystickPresent , getJoystickAxes , getJoystickButtons @@ -224,6 +232,8 @@ type CharCallback = Window -> Char -> IO () type MonitorCallback = Monitor -> MonitorState -> IO () +-- 3.1 additions + -------------------------------------------------------------------------------- -- CB scheduling @@ -500,6 +510,7 @@ windowPosFun <- newIORef nullFunPtr windowRefreshFun <- newIORef nullFunPtr windowSizeFun <- newIORef nullFunPtr + dropFun <- newIORef nullFunPtr let callbacks = WindowCallbacks { storedCharFun = charFun , storedCursorEnterFun = cursorEnterFun @@ -514,6 +525,7 @@ , storedWindowPosFun = windowPosFun , storedWindowRefreshFun = windowRefreshFun , storedWindowSizeFun = windowSizeFun + , storedDropFun = dropFun } p'win <- c'glfwCreateWindow (toC w) @@ -809,6 +821,7 @@ storedKeyFun win + setCharCallback :: Window -> Maybe CharCallback -> IO () setCharCallback win = setWindowCallback mk'GLFWcharfun @@ -932,3 +945,68 @@ if p's == nullPtr then return Nothing else Just `fmap` peekCString p's + +-------------------------------------------------------------------------------- +-- 3.1 additions (http://www.glfw.org/docs/latest/news.html#news_31) +-------------------------------------------------------------------------------- + +-- Cursor Objects +-- http://www.glfw.org/docs/latest/input.html#cursor_object + +-- | Creates a new cursor. +createCursor :: Image -- ^ The desired cursor image. + -> Int -- ^ The desired x-coordinate, in pixels, of the cursor + -- hotspot. + -> Int -- ^ The desired y-coordinate, in pixels, of the cursor + -- hotspot. + -> IO Cursor +createCursor (Image w h pxs) x y = + alloca $ \p'img -> + withArray pxs $ \p'pxs -> do + let img = C'GLFWimage (toC w) + (toC h) + p'pxs + poke p'img img + Cursor <$> c'glfwCreateCursor p'img (toC x) (toC y) + +-- | Creates a cursor with a standard shape that can be set for a window with +-- setCursor. +createStandardCursor :: StandardCursorShape -> IO Cursor +createStandardCursor = (Cursor <$>) . c'glfwCreateStandardCursor . toC + +-- | Sets the cursor image to be used when the cursor is over the client area +-- of the specified window. The set cursor will only be visible when the cursor +-- mode of the window is GLFW_CURSOR_NORMAL. + +-- On some platforms, the set cursor may not be visible unless the window also +-- has input focus. +setCursor :: Window -> Cursor -> IO () +setCursor (Window wptr) (Cursor cptr) = c'glfwSetCursor wptr cptr + +-- | Destroys a cursor previously created with `createCursor`. Any remaining +-- cursors will be destroyed by `terminate`. +destroyCursor :: Cursor -> IO () +destroyCursor = c'glfwDestroyCursor . unCursor + +-- Path Drop Input +-- http://www.glfw.org/docs/latest/input.html#path_drop + +type DropCallback = Window -- ^ The window that received the event. + -> [String] -- ^ The file and/or directory path names + -> IO () + +-- | Sets the file drop callback of the specified window, which is called when +-- one or more dragged files are dropped on the window. +setDropCallback :: Window -> Maybe DropCallback -> IO () +setDropCallback win = setWindowCallback + mk'GLFWdropfun + (\cb w c fs -> do + let count = fromC c + fps <- flip mapM [0..count-1] $ \i -> do + let p = advancePtr fs i + p' <- peek p + peekCString p' + schedule $ cb (fromC w) fps) + (c'glfwSetDropCallback (toC win)) + storedDropFun + win diff --git a/Graphics/UI/GLFW/C.hs b/Graphics/UI/GLFW/C.hs --- a/Graphics/UI/GLFW/C.hs +++ b/Graphics/UI/GLFW/C.hs @@ -12,7 +12,7 @@ import Data.Bits ((.&.)) import Data.Char (chr, ord) -import Foreign.C.Types (CDouble, CFloat, CInt, CUChar, CUInt, CUShort) +import Foreign.C.Types (CDouble, CFloat, CInt, CChar, CUChar, CUInt, CUShort) import Foreign.Ptr (Ptr) import Bindings.GLFW @@ -26,6 +26,10 @@ -------------------------------------------------------------------------------- +instance C CChar Char where + fromC = chr . fromIntegral + toC = fromIntegral . ord + instance C CInt Char where fromC = chr . fromIntegral toC = fromIntegral . ord @@ -527,6 +531,26 @@ | otherwise = error $ "C CInt StickyMouseButtonsInputMode fromC: " ++ show v toC StickyMouseButtonsInputMode'Enabled = c'GL_TRUE toC StickyMouseButtonsInputMode'Disabled = c'GL_FALSE + +-------------------------------------------------------------------------------- +-- 3.1 Additions +-------------------------------------------------------------------------------- + +instance C CInt StandardCursorShape where + fromC v + | v == c'GLFW_ARROW_CURSOR = StandardCursorShape'Arrow + | v == c'GLFW_IBEAM_CURSOR = StandardCursorShape'IBeam + | v == c'GLFW_CROSSHAIR_CURSOR = StandardCursorShape'Crosshair + | v == c'GLFW_HAND_CURSOR = StandardCursorShape'Hand + | v == c'GLFW_HRESIZE_CURSOR = StandardCursorShape'HResize + | v == c'GLFW_VRESIZE_CURSOR = StandardCursorShape'VResize + | otherwise = error $ "C CInt StandardCursorShape fromC: " ++ show v + toC StandardCursorShape'Arrow = c'GLFW_ARROW_CURSOR + toC StandardCursorShape'IBeam = c'GLFW_IBEAM_CURSOR + toC StandardCursorShape'Crosshair = c'GLFW_CROSSHAIR_CURSOR + toC StandardCursorShape'Hand = c'GLFW_HAND_CURSOR + toC StandardCursorShape'HResize = c'GLFW_HRESIZE_CURSOR + toC StandardCursorShape'VResize = c'GLFW_VRESIZE_CURSOR -------------------------------------------------------------------------------- diff --git a/Graphics/UI/GLFW/Types.hs b/Graphics/UI/GLFW/Types.hs --- a/Graphics/UI/GLFW/Types.hs +++ b/Graphics/UI/GLFW/Types.hs @@ -1,14 +1,17 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Graphics.UI.GLFW.Types where -------------------------------------------------------------------------------- -import Data.Data (Data) -import Data.IORef (IORef) -import Data.Typeable (Typeable) -import Foreign.Ptr (Ptr) +import Data.Data (Data) +import Data.IORef (IORef) +import Data.Typeable (Typeable) +import Foreign.Ptr (Ptr) +import Foreign.C.Types (CUChar(..)) import GHC.Generics import Bindings.GLFW @@ -95,6 +98,7 @@ , storedWindowPosFun :: IORef C'GLFWwindowposfun , storedWindowRefreshFun :: IORef C'GLFWwindowrefreshfun , storedWindowSizeFun :: IORef C'GLFWwindowsizefun + , storedDropFun :: IORef C'GLFWdropfun } newtype Window = Window @@ -356,6 +360,31 @@ , modifierKeysAlt :: Bool , modifierKeysSuper :: Bool } deriving (Data, Eq, Ord, Read, Show, Typeable, Generic) + +-------------------------------------------------------------------------------- +-- 3.1 Additions +-------------------------------------------------------------------------------- + +deriving instance Data CUChar + +data Image = Image + { imageWidth :: Int + , imageHeight :: Int + , imagePixels :: [CUChar] + } deriving (Data, Eq, Ord, Read, Show, Typeable, Generic) + +newtype Cursor = Cursor + { unCursor :: Ptr C'GLFWcursor + } deriving (Data, Eq, Ord, Show, Typeable, Generic) + +data StandardCursorShape = + StandardCursorShape'Arrow + | StandardCursorShape'IBeam + | StandardCursorShape'Crosshair + | StandardCursorShape'Hand + | StandardCursorShape'HResize + | StandardCursorShape'VResize + deriving (Data, Enum, Eq, Ord, Read, Show, Typeable, Generic) --------------------------------------------------------------------------------