diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,46 @@ +# Change Log / Release Notes + +## 1.10.3 (2022-09-14) + + * Added `cWX`, `cWY`, `cWWidth`, `cWHeight` constants (`AttributeMask`) (#82) + + * Added `FocusChangeEvent` to `data Event` (#81) + + * Added `setWMNormalHints` (#83) + +## 1.10.2 (2021-10-24) + + * Restored compatibility with GHC 7.10 (and possibly even older) (#80) + +## 1.10.1 (2021-08-15) + + * Fixed possible high CPU usage of some blocking calls with the threaded RTS (#78) + +## 1.10 (2021-05-31) + + * Added `setClientMessageEvent'` (#71) + + * Fixed type of `xrrUpdateConfiguration` (#72) + + * Fixed bottom when deserializing XRRNotifyEvent in `getEvent` (#72) + + * Added `xrrGetMonitors` and `XRRMonitorInfo` (#42) + + * Added `setClassHint` (#76) + + * Added a few missing event mask fields to `WindowAttributes` (#77) + +## 1.9.2 (2020-08-25) + + * Make sure that X11 search paths determined by autoconf are actually passed + through to Cabal. The fix was contributed by Greg Steuck (#53, #69). + + * Locate the include statement for `HsAllKeysyms.h` above the relevant ifdefs + to avoid issues during cross compilation. The fix was contributed by + Vanessa McHale (#65) + +## 1.8 (February 9, 2017) + + * Added `deleteProperty` + + * Add SelectionClear event to xlib Extra diff --git a/Graphics/X11.hs b/Graphics/X11.hs --- a/Graphics/X11.hs +++ b/Graphics/X11.hs @@ -3,7 +3,7 @@ -- Module : Graphics.X11 -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable @@ -12,11 +12,11 @@ -- ----------------------------------------------------------------------------- -module Graphics.X11 +module Graphics.X11 ( module Graphics.X11.Xlib ) where -import Graphics.X11.Xlib +import Graphics.X11.Xlib ---------------------------------------------------------------- -- End diff --git a/Graphics/X11/ExtraTypes.hs b/Graphics/X11/ExtraTypes.hs --- a/Graphics/X11/ExtraTypes.hs +++ b/Graphics/X11/ExtraTypes.hs @@ -3,7 +3,7 @@ -- Module : Graphics.X11.ExtraTypes -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : unstable -- Portability : unportable @@ -13,24 +13,24 @@ ----------------------------------------------------------------------------- module Graphics.X11.ExtraTypes - ( - -- * Types - module Graphics.X11.ExtraTypes.AP, - module Graphics.X11.ExtraTypes.DEC, - module Graphics.X11.ExtraTypes.HP, - module Graphics.X11.ExtraTypes.Sun, - module Graphics.X11.ExtraTypes.XF86, - module Graphics.X11.ExtraTypes.XorgDefault, - - ) where + ( + -- * Types + module Graphics.X11.ExtraTypes.AP, + module Graphics.X11.ExtraTypes.DEC, + module Graphics.X11.ExtraTypes.HP, + module Graphics.X11.ExtraTypes.Sun, + module Graphics.X11.ExtraTypes.XF86, + module Graphics.X11.ExtraTypes.XorgDefault, + ) where + import Graphics.X11.ExtraTypes.AP import Graphics.X11.ExtraTypes.DEC import Graphics.X11.ExtraTypes.HP import Graphics.X11.ExtraTypes.Sun import Graphics.X11.ExtraTypes.XF86 import Graphics.X11.ExtraTypes.XorgDefault - + ---------------------------------------------------------------- -- End ---------------------------------------------------------------- diff --git a/Graphics/X11/ExtraTypes/HP.hsc b/Graphics/X11/ExtraTypes/HP.hsc --- a/Graphics/X11/ExtraTypes/HP.hsc +++ b/Graphics/X11/ExtraTypes/HP.hsc @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- +-- -- Module : Graphics.X11.ExtraTypes.HP -- Copyright : (c) Open Group 1987,1998, DEC 1987 -- License : X11 (see below) due to X headers diff --git a/Graphics/X11/ExtraTypes/XF86.hsc b/Graphics/X11/ExtraTypes/XF86.hsc --- a/Graphics/X11/ExtraTypes/XF86.hsc +++ b/Graphics/X11/ExtraTypes/XF86.hsc @@ -19,6 +19,7 @@ -- Presumably XFree86/X.org has copyright on the header but it's not -- explicit in the file. +#include "HsAllKeysyms.h" module Graphics.X11.ExtraTypes.XF86 ( @@ -688,6 +689,146 @@ #else -- Skipping xF86XK_Music because your X doesn't define it #endif +#ifdef XF86XK_Battery + xF86XK_Battery, -- Display battery information +#else + -- Skipping XF86XK_Battery because your X doesn't define it +#endif +#ifdef XF86XK_Bluetooth + xF86XK_Bluetooth, -- Enable/disable Bluetooth +#else + -- Skipping XF86XK_Bluetooth because your X doesn't define it +#endif +#ifdef XF86XK_WLAN + xF86XK_WLAN, -- Enable/disable WLAN +#else + -- Skipping XF86XK_WLAN because your X doesn't define it +#endif +#ifdef XF86XK_UWB + xF86XK_UWB, -- Enable/disable UWB +#else + -- Skipping XF86XK_UWB because your X doesn't define it +#endif +#ifdef XF86XK_AudioForward + xF86XK_AudioForward, -- Fast-forward audio track +#else + -- Skipping XF86XK_AudioForward because your X doesn't define it +#endif +#ifdef XF86XK_AudioRepeat + xF86XK_AudioRepeat, -- Toggle repeat mode +#else + -- Skipping XF86XK_AudioRepeat because your X doesn't define it +#endif +#ifdef XF86XK_AudioRandomPlay + xF86XK_AudioRandomPlay, -- Toggle shuffle mode +#else + -- Skipping XF86XK_AudioRandomPlay because your X doesn't define it +#endif +#ifdef XF86XK_Subtitle + xF86XK_Subtitle, -- Cycle through subtitle +#else + -- Skipping XF86XK_Subtitle because your X doesn't define it +#endif +#ifdef XF86XK_AudioCycleTrack + xF86XK_AudioCycleTrack, -- Cycle through audio tracks +#else + -- Skipping XF86XK_AudioCycleTrack because your X doesn't define it +#endif +#ifdef XF86XK_CycleAngle + xF86XK_CycleAngle, -- Cycle through angles +#else + -- Skipping XF86XK_CycleAngle because your X doesn't define it +#endif +#ifdef XF86XK_FrameBack + xF86XK_FrameBack, -- Video: go one frame back +#else + -- Skipping XF86XK_FrameBack because your X doesn't define it +#endif +#ifdef XF86XK_FrameForward + xF86XK_FrameForward, -- Video: go one frame forward +#else + -- Skipping XF86XK_FrameForward because your X doesn't define it +#endif +#ifdef XF86XK_Time + xF86XK_Time, -- Display, or shows an entry for time seeking +#else + -- Skipping XF86XK_Time because your X doesn't define it +#endif +#ifdef XF86XK_Select + xF86XK_Select, -- Select button on joypads and remotes +#else + -- Skipping XF86XK_Select because your X doesn't define it +#endif +#ifdef XF86XK_View + xF86XK_View, -- Show a view options/properties +#else + -- Skipping XF86XK_View because your X doesn't define it +#endif +#ifdef XF86XK_TopMenu + xF86XK_TopMenu, -- Go to a top-level menu in a video +#else + -- Skipping XF86XK_TopMenu because your X doesn't define it +#endif +#ifdef XF86XK_Red + xF86XK_Red, -- Red button +#else + -- Skipping XF86XK_Red because your X doesn't define it +#endif +#ifdef XF86XK_Green + xF86XK_Green, -- Green button +#else + -- Skipping XF86XK_Green because your X doesn't define it +#endif +#ifdef XF86XK_Yellow + xF86XK_Yellow, -- Yellow button +#else + -- Skipping XF86XK_Yellow because your X doesn't define it +#endif +#ifdef XF86XK_Blue + xF86XK_Blue, -- Blue button +#else + -- Skipping XF86XK_Blue because your X doesn't define it +#endif +#ifdef XF86XK_Suspend + xF86XK_Suspend, -- Sleep to RAM +#else + -- Skipping XF86XK_Suspend because your X doesn't define it +#endif +#ifdef XF86XK_Hibernate + xF86XK_Hibernate, -- Sleep to disk +#else + -- Skipping XF86XK_Hibernate because your X doesn't define it +#endif +#ifdef XF86XK_TouchpadToggle + xF86XK_TouchpadToggle, -- Toggle between touchpad/trackstick +#else + -- Skipping XF86XK_TouchpadToggle because your X doesn't define it +#endif +#ifdef XF86XK_TouchpadOn + xF86XK_TouchpadOn, -- The touchpad got switched on +#else + -- Skipping XF86XK_TouchpadOn because your X doesn't define it +#endif +#ifdef XF86XK_TouchpadOff + xF86XK_TouchpadOff, -- The touchpad got switched off +#else + -- Skipping XF86XK_TouchpadOff because your X doesn't define it +#endif +#ifdef XF86XK_AudioMicMute + xF86XK_AudioMicMute, -- Mute the Mic from the system +#else + -- Skipping XF86XK_AudioMicMute because your X doesn't define it +#endif +#ifdef XF86XK_LogWindowTree + xF86XK_LogWindowTree, -- Print window tree to log +#else + -- Skipping XF86XK_LogWindowTree because your X doesn't define it +#endif +#ifdef XF86XK_LogGrabInfo + xF86XK_LogGrabInfo, -- Print all active grabs to log +#else + -- Skipping XF86XK_LogGrabInfo because your X doesn't define it +#endif #ifdef XF86XK_Switch_VT_1 xF86XK_Switch_VT_1, #else @@ -772,8 +913,6 @@ import Graphics.X11.Types -#include "HsAllKeysyms.h" - #ifdef XF86XK_ModeLock xF86XK_ModeLock :: KeySym xF86XK_ModeLock = #const XF86XK_ModeLock @@ -1305,6 +1444,118 @@ #ifdef XF86XK_Music xF86XK_Music :: KeySym xF86XK_Music = #const XF86XK_Music +#endif +#ifdef XF86XK_Battery +xF86XK_Battery :: KeySym +xF86XK_Battery = #const XF86XK_Battery +#endif +#ifdef XF86XK_Bluetooth +xF86XK_Bluetooth :: KeySym +xF86XK_Bluetooth = #const XF86XK_Bluetooth +#endif +#ifdef XF86XK_WLAN +xF86XK_WLAN :: KeySym +xF86XK_WLAN = #const XF86XK_WLAN +#endif +#ifdef XF86XK_UWB +xF86XK_UWB :: KeySym +xF86XK_UWB = #const XF86XK_UWB +#endif +#ifdef XF86XK_AudioForward +xF86XK_AudioForward :: KeySym +xF86XK_AudioForward = #const XF86XK_AudioForward +#endif +#ifdef XF86XK_AudioRepeat +xF86XK_AudioRepeat :: KeySym +xF86XK_AudioRepeat = #const XF86XK_AudioRepeat +#endif +#ifdef XF86XK_AudioRandomPlay +xF86XK_AudioRandomPlay :: KeySym +xF86XK_AudioRandomPlay = #const XF86XK_AudioRandomPlay +#endif +#ifdef XF86XK_Subtitle +xF86XK_Subtitle :: KeySym +xF86XK_Subtitle = #const XF86XK_Subtitle +#endif +#ifdef XF86XK_AudioCycleTrack +xF86XK_AudioCycleTrack :: KeySym +xF86XK_AudioCycleTrack = #const XF86XK_AudioCycleTrack +#endif +#ifdef XF86XK_CycleAngle +xF86XK_CycleAngle :: KeySym +xF86XK_CycleAngle = #const XF86XK_CycleAngle +#endif +#ifdef XF86XK_FrameBack +xF86XK_FrameBack :: KeySym +xF86XK_FrameBack = #const XF86XK_FrameBack +#endif +#ifdef XF86XK_FrameForward +xF86XK_FrameForward :: KeySym +xF86XK_FrameForward = #const XF86XK_FrameForward +#endif +#ifdef XF86XK_Time +xF86XK_Time :: KeySym +xF86XK_Time = #const XF86XK_Time +#endif +#ifdef XF86XK_Select +xF86XK_Select :: KeySym +xF86XK_Select = #const XF86XK_Select +#endif +#ifdef XF86XK_View +xF86XK_View :: KeySym +xF86XK_View = #const XF86XK_View +#endif +#ifdef XF86XK_TopMenu +xF86XK_TopMenu :: KeySym +xF86XK_TopMenu = #const XF86XK_TopMenu +#endif +#ifdef XF86XK_Red +xF86XK_Red :: KeySym +xF86XK_Red = #const XF86XK_Red +#endif +#ifdef XF86XK_Green +xF86XK_Green :: KeySym +xF86XK_Green = #const XF86XK_Green +#endif +#ifdef XF86XK_Yellow +xF86XK_Yellow :: KeySym +xF86XK_Yellow = #const XF86XK_Yellow +#endif +#ifdef XF86XK_Blue +xF86XK_Blue :: KeySym +xF86XK_Blue = #const XF86XK_Blue +#endif +#ifdef XF86XK_Suspend +xF86XK_Suspend :: KeySym +xF86XK_Suspend = #const XF86XK_Suspend +#endif +#ifdef XF86XK_Hibernate +xF86XK_Hibernate :: KeySym +xF86XK_Hibernate = #const XF86XK_Hibernate +#endif +#ifdef XF86XK_TouchpadToggle +xF86XK_TouchpadToggle :: KeySym +xF86XK_TouchpadToggle = #const XF86XK_TouchpadToggle +#endif +#ifdef XF86XK_TouchpadOn +xF86XK_TouchpadOn :: KeySym +xF86XK_TouchpadOn = #const XF86XK_TouchpadOn +#endif +#ifdef XF86XK_TouchpadOff +xF86XK_TouchpadOff :: KeySym +xF86XK_TouchpadOff = #const XF86XK_TouchpadOff +#endif +#ifdef XF86XK_AudioMicMute +xF86XK_AudioMicMute :: KeySym +xF86XK_AudioMicMute = #const XF86XK_AudioMicMute +#endif +#ifdef XF86XK_LogWindowTree +xF86XK_LogWindowTree :: KeySym +xF86XK_LogWindowTree = #const XF86XK_LogWindowTree +#endif +#ifdef XF86XK_LogGrabInfo +xF86XK_LogGrabInfo :: KeySym +xF86XK_LogGrabInfo = #const XF86XK_LogGrabInfo #endif #ifdef XF86XK_Switch_VT_1 xF86XK_Switch_VT_1 :: KeySym diff --git a/Graphics/X11/Types.hsc b/Graphics/X11/Types.hsc --- a/Graphics/X11/Types.hsc +++ b/Graphics/X11/Types.hsc @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.X11.Types @@ -28,6 +29,13 @@ Colormap, GContext, KeyCode, + SizeID, + SubpixelOrder, + Connection, + RROutput, + RRCrtc, + RRMode, + XRRModeFlags, -- * Enumeration types -- | These types were introduced to make function types clearer. @@ -50,7 +58,7 @@ xK_Delete, xK_Multi_key, - -- SunOS does not define these. + -- SunOS does not define these. #ifdef XK_Codeinput xK_Codeinput, #endif @@ -423,6 +431,12 @@ propertyChangeMask, colormapChangeMask, ownerGrabButtonMask, + rrScreenChangeNotifyMask, + rrCrtcChangeNotifyMask, + rrOutputChangeNotifyMask, + rrOutputPropertyNotifyMask, + screenSaverCycleMask, + screenSaverNotifyMask, -- ** Event types EventType, @@ -459,7 +473,13 @@ colormapNotify, clientMessage, mappingNotify, + rrScreenChangeNotify, + rrNotify, + rrNotifyCrtcChange, + rrNotifyOutputChange, + rrNotifyOutputProperty, lASTEvent, + screenSaverNotify, -- ** Modifiers Modifier, @@ -475,6 +495,7 @@ -- ** Key masks KeyMask, + noModMask, shiftMask, lockMask, controlMask, @@ -626,6 +647,10 @@ cWDontPropagate, cWColormap, cWCursor, + cWX, + cWY, + cWWidth, + cWHeight, -- ** Close down modes CloseDownMode, @@ -799,7 +824,20 @@ ImageFormat, xyBitmap, xyPixmap, - zPixmap + zPixmap, + + -- ** Reflection and Rotation + Rotation, + Reflection, + xRR_Rotate_0, + xRR_Rotate_90, + xRR_Rotate_180, + xRR_Rotate_270, + xRR_Reflect_X, + xRR_Reflect_Y, + xRR_Connected, + xRR_Disconnected, + xRR_UnknownConnection ) where -- import Data.Int @@ -1254,6 +1292,12 @@ , propertyChangeMask = PropertyChangeMask , colormapChangeMask = ColormapChangeMask , ownerGrabButtonMask = OwnerGrabButtonMask + , rrScreenChangeNotifyMask = RRScreenChangeNotifyMask + , rrCrtcChangeNotifyMask = RRCrtcChangeNotifyMask + , rrOutputChangeNotifyMask = RROutputChangeNotifyMask + , rrOutputPropertyNotifyMask = RROutputPropertyNotifyMask + , screenSaverCycleMask = ScreenSaverCycleMask + , screenSaverNotifyMask = ScreenSaverNotifyMask } type EventType = Word32 @@ -1291,7 +1335,13 @@ , colormapNotify = ColormapNotify , clientMessage = ClientMessage , mappingNotify = MappingNotify + , rrScreenChangeNotify = RRScreenChangeNotify + , rrNotify = RRNotify + , rrNotifyCrtcChange = RRNotify_CrtcChange + , rrNotifyOutputChange = RRNotify_OutputChange + , rrNotifyOutputProperty=RRNotify_OutputProperty , lASTEvent = LASTEvent + , screenSaverNotify = ScreenSaverNotify } type Modifier = CUInt @@ -1309,6 +1359,7 @@ type KeyMask = Modifier #{enum KeyMask, + , noModMask = 0 , shiftMask = ShiftMask , lockMask = LockMask , controlMask = ControlMask @@ -1489,6 +1540,10 @@ , cWDontPropagate = CWDontPropagate , cWColormap = CWColormap , cWCursor = CWCursor + , cWX = CWX + , cWY = CWY + , cWWidth = CWWidth + , cWHeight = CWHeight } -- Used in ChangeCloseDownMode @@ -1717,4 +1772,33 @@ , xyBitmap = XYBitmap , xyPixmap = XYPixmap , zPixmap = ZPixmap + } + +-- Xrandr types +type Rotation = #{type Rotation} +type Reflection = #{type Rotation} +type SizeID = #{type SizeID} +type SubpixelOrder = #{type SubpixelOrder} +type Connection = #{type Connection} +type RROutput = #{type RROutput} +type RRCrtc = #{type RRCrtc} +type RRMode = #{type RRMode} +type XRRModeFlags = #{type XRRModeFlags} + +#{enum Rotation, + , xRR_Rotate_0 = RR_Rotate_0 + , xRR_Rotate_90 = RR_Rotate_90 + , xRR_Rotate_180 = RR_Rotate_180 + , xRR_Rotate_270 = RR_Rotate_270 + } + +#{enum Reflection, + , xRR_Reflect_X = RR_Reflect_X + , xRR_Reflect_Y = RR_Reflect_Y + } + +#{enum Connection, + , xRR_Connected = RR_Connected + , xRR_Disconnected = RR_Disconnected + , xRR_UnknownConnection = RR_UnknownConnection } diff --git a/Graphics/X11/XScreenSaver.hsc b/Graphics/X11/XScreenSaver.hsc new file mode 100644 --- /dev/null +++ b/Graphics/X11/XScreenSaver.hsc @@ -0,0 +1,425 @@ +{-# LANGUAGE DeriveDataTypeable, ForeignFunctionInterface #-} +-------------------------------------------------------------------- +-- | +-- Module : Graphics.X11.XScreenSaver +-- Copyright : (c) Joachim Breitner +-- (c) Jochen Keil +-- License : BSD3 +-- +-- Maintainer: Joachim Breitner +-- Stability : provisional +-- Portability: portable +-- +-------------------------------------------------------------------- +-- +-- Interface to XScreenSaver API +-- + +module Graphics.X11.XScreenSaver ( + getXIdleTime, + XScreenSaverState(..), + XScreenSaverKind(..), + XScreenSaverInfo(..), + XScreenSaverNotifyEvent, + xScreenSaverQueryExtension, + xScreenSaverQueryVersion, + xScreenSaverQueryInfo, + xScreenSaverSelectInput, + xScreenSaverSetAttributes, + xScreenSaverUnsetAttributes, + xScreenSaverSaverRegister, + xScreenSaverUnregister, + xScreenSaverGetRegistered, + xScreenSaverSuspend, + get_XScreenSaverNotifyEvent, + compiledWithXScreenSaver + ) where + +import Graphics.X11.Types +import Graphics.X11.Xlib.Types + +import Foreign +import Foreign.C.Types +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Internal + +import Control.Monad + +-- | XScreenSaverState is for use in both XScreenSaverNotifyEvent and +-- XScreenSaverInfo +-- ScreenSaverCycle is not a valid value for use in XScreenSaverInfo +-- ScreenSaverDisabled will not occur in an XScreenSaverNotifyEvent +data XScreenSaverState + -- | The screen is not currently being saved; til-or-since specifies the + -- number of milliseconds until the screen saver is expected to activate. + = ScreenSaverOff + -- | The screen is currently being saved; til-or-since specifies the number + -- of milliseconds since the screen saver activated. + | ScreenSaverOn + -- | If this bit is set, ScreenSaverNotify events are generated + -- whenever the screen saver cycle interval passes. + | ScreenSaverCycle + -- | The screen saver is currently disabled; til-or-since is zero. + | ScreenSaverDisabled + deriving Show + +-- | Data type for use in a XScreenSaverInfo struct +data XScreenSaverKind + -- | The video signal to the display monitor was disabled. + = ScreenSaverBlanked + -- | A server-dependent, built-in screen saver image was displayed; either + -- no client had set the screen saver window attributes or a different + -- client had the server grabbed when the screen saver activated. + | ScreenSaverInternal + -- | The screen saver window was mapped with attributes set by a client + -- using the ScreenSaverSetAttributes request. + | ScreenSaverExternal + deriving Show + +-- | Representation of the XScreenSaverInfo struct. +data XScreenSaverInfo = XScreenSaverInfo + { xssi_window :: !Window + -- | The state field specified whether or not the screen saver is + -- currently active and how the til-or-since value should be interpreted + , xssi_state :: !XScreenSaverState + -- | The kind field specifies the mechanism that either is currently + -- being used or would have been were the screen being saved + , xssi_kind :: !XScreenSaverKind + , xssi_til_or_since :: !CULong + -- | The idle field specifies the number of milliseconds since the last + -- input was received from the user on any of the input devices. + , xssi_idle :: !CULong + -- | The event-mask field specifies which, if any, screen saver events + -- this client has requested using ScreenSaverSelectInput. + , xssi_event_mask :: !CULong + } deriving (Show) + + +-- | Simple wrapper around 'xScreenSaverQueryInfo' if you are only interested in +-- the idle time, in milliseconds. Returns 0 if the XScreenSaver extension is +-- not available +getXIdleTime :: Display -> IO Int +getXIdleTime dpy = + maybe 0 (fromIntegral . xssi_idle) `fmap` xScreenSaverQueryInfo dpy + +-- | We have XScreenSaver, so the library will actually work +compiledWithXScreenSaver :: Bool +compiledWithXScreenSaver = True +{-# DEPRECATED compiledWithXScreenSaver "X11 now always compiles with XScreenSaver support" #-} + + +-- for XFree() (already included from scrnsaver.h, but I don't know if I can +-- count on that.) +#include +#include + +xScreenSaverState2CInt :: XScreenSaverState -> CInt +xScreenSaverState2CInt ScreenSaverOn = #const ScreenSaverOn +xScreenSaverState2CInt ScreenSaverOff = #const ScreenSaverOff +xScreenSaverState2CInt ScreenSaverCycle = #const ScreenSaverCycle +xScreenSaverState2CInt ScreenSaverDisabled = #const ScreenSaverDisabled + +cInt2XScreenSaverState :: CInt -> XScreenSaverState +cInt2XScreenSaverState (#const ScreenSaverOn) = ScreenSaverOn +cInt2XScreenSaverState (#const ScreenSaverOff) = ScreenSaverOff +cInt2XScreenSaverState (#const ScreenSaverCycle) = ScreenSaverCycle +cInt2XScreenSaverState (#const ScreenSaverDisabled) = ScreenSaverDisabled +cInt2XScreenSaverState s = error $ + "Unknown state in xScreenSaverQueryInfo for XScreenSaverState: " ++ show s + +instance Storable XScreenSaverState where + sizeOf _ = sizeOf (undefined :: CInt) + alignment _ = alignment (undefined :: CInt) + poke p xsss = poke (castPtr p) (xScreenSaverState2CInt xsss) + peek p = cInt2XScreenSaverState `fmap` peek (castPtr p) + + +xScreenSaverKind2CInt :: XScreenSaverKind -> CInt +xScreenSaverKind2CInt ScreenSaverBlanked = #const ScreenSaverBlanked +xScreenSaverKind2CInt ScreenSaverInternal = #const ScreenSaverInternal +xScreenSaverKind2CInt ScreenSaverExternal = #const ScreenSaverExternal + +cInt2XScreenSaverKind :: CInt -> XScreenSaverKind +cInt2XScreenSaverKind (#const ScreenSaverBlanked) = ScreenSaverBlanked +cInt2XScreenSaverKind (#const ScreenSaverInternal) = ScreenSaverInternal +cInt2XScreenSaverKind (#const ScreenSaverExternal) = ScreenSaverExternal +cInt2XScreenSaverKind s = error $ + "Unknown kind in xScreenSaverQueryInfo for XScreenSaverKind: " ++ show s + +instance Storable XScreenSaverKind where + sizeOf _ = sizeOf (undefined :: CInt) + alignment _ = alignment (undefined :: CInt) + poke p xsss = poke (castPtr p) (xScreenSaverKind2CInt xsss) + peek p = cInt2XScreenSaverKind `fmap` peek (castPtr p) + + +instance Storable XScreenSaverInfo where + sizeOf _ = #{size XScreenSaverInfo} + -- FIXME: Is this right? + alignment _ = alignment (undefined :: CInt) + + poke p xssi = do + #{poke XScreenSaverInfo, window } p $ xssi_window xssi + #{poke XScreenSaverInfo, state } p $ xssi_state xssi + #{poke XScreenSaverInfo, kind } p $ xssi_kind xssi + #{poke XScreenSaverInfo, til_or_since } p $ xssi_til_or_since xssi + #{poke XScreenSaverInfo, idle } p $ xssi_idle xssi + #{poke XScreenSaverInfo, eventMask } p $ xssi_event_mask xssi + + peek p = return XScreenSaverInfo + `ap` (#{peek XScreenSaverInfo, window} p) + `ap` (#{peek XScreenSaverInfo, state} p) + `ap` (#{peek XScreenSaverInfo, kind} p) + `ap` (#{peek XScreenSaverInfo, til_or_since} p) + `ap` (#{peek XScreenSaverInfo, idle} p) + `ap` (#{peek XScreenSaverInfo, eventMask} p) + +type XScreenSaverNotifyEvent = + ( Window -- screen saver window + , Window -- root window of event screen + , CInt -- State: ScreenSaver{Off,On,Cycle} + , CInt -- Kind: ScreenSaver{Blanked,Internal,External} + , Bool -- extents of new region + , Time -- event timestamp + ) + +pokeXScreenSaverNotifyEvent :: Ptr XScreenSaverNotifyEvent + -> XScreenSaverNotifyEvent -> IO () +pokeXScreenSaverNotifyEvent p (window, root, state, kind, forced, time) = do + #{poke XScreenSaverNotifyEvent, window } p window + #{poke XScreenSaverNotifyEvent, root } p root + #{poke XScreenSaverNotifyEvent, state } p state + #{poke XScreenSaverNotifyEvent, kind } p kind + #{poke XScreenSaverNotifyEvent, forced } p forced + #{poke XScreenSaverNotifyEvent, time } p time + +peekXScreenSaverNotifyEvent :: Ptr XScreenSaverNotifyEvent + -> IO XScreenSaverNotifyEvent +peekXScreenSaverNotifyEvent p = do + window <- (#{peek XScreenSaverNotifyEvent, window } p ) + root <- (#{peek XScreenSaverNotifyEvent, root } p ) + state <- (#{peek XScreenSaverNotifyEvent, state } p ) + kind <- (#{peek XScreenSaverNotifyEvent, kind } p ) + forced <- (#{peek XScreenSaverNotifyEvent, forced } p ) + time <- (#{peek XScreenSaverNotifyEvent, time } p ) + return (window, root, state, kind, forced, time) + +get_XScreenSaverNotifyEvent :: XEventPtr -> IO XScreenSaverNotifyEvent +get_XScreenSaverNotifyEvent p = peekXScreenSaverNotifyEvent (castPtr p) + +xScreenSaverQueryExtension :: Display -> IO (Maybe (CInt, CInt)) +xScreenSaverQueryExtension dpy = wrapPtr2 (cXScreenSaverQueryExtension dpy) go + where go False _ _ = Nothing + go True eventbase errorbase = Just ( fromIntegral eventbase + , fromIntegral errorbase + ) + +xScreenSaverQueryVersion :: Display -> IO (Maybe (CInt, CInt)) +xScreenSaverQueryVersion dpy = wrapPtr2 (cXScreenSaverQueryVersion dpy) go + where go False _ _ = Nothing + go True major minor = Just (fromIntegral major, fromIntegral minor) + +wrapPtr2 :: (Storable a, Storable b) + => (Ptr a -> Ptr b -> IO c) -> (c -> a -> b -> d) -> IO d +wrapPtr2 cfun f = withPool $ \pool -> do aptr <- pooledMalloc pool + bptr <- pooledMalloc pool + ret <- cfun aptr bptr + a <- peek aptr + b <- peek bptr + return (f ret a b) + +-- | xScreenSaverQueryInfo returns information about the current state of the +-- screen server. If the xScreenSaver extension is not available, it returns +-- Nothing +xScreenSaverQueryInfo :: Display -> IO (Maybe XScreenSaverInfo) +xScreenSaverQueryInfo dpy = do + p <- cXScreenSaverAllocInfo + if p == nullPtr then return Nothing else do + s <- cXScreenSaverQueryInfo dpy (defaultRootWindow dpy) p + if s == 0 then return Nothing else do + xssi <- peek p + _ <- xFree p + return (Just xssi) + +-- | xScreenSaverSelectInput asks that events related to the screen saver be +-- generated for this client. If no bits are set in event-mask, then no events +-- will be generated. +xScreenSaverSelectInput :: Display -> EventMask -> IO () +xScreenSaverSelectInput dpy xssem = do + p <- cXScreenSaverAllocInfo + if p == nullPtr then return () else do + cXScreenSaverSelectInput dpy (defaultRootWindow dpy) xssem + +-- | XScreenSaverSetAttributes sets the attributes to be used the next time +-- the external screen saver is activated. If another client currently +-- has the attributes set, a BadAccess error is generated and the request +-- is ignored. +-- +-- Otherwise, the specified window attributes are checked as if they were +-- used in a core CreateWindow request whose parent is the root. The +-- override-redirect field is ignored as it is implicitly set to True. If +-- the window attributes result in an error according to the rules for +-- CreateWindow, the request is ignored. +-- +-- Otherwise, the attributes are stored and will take effect on the next +-- activation that occurs when the server is not grabbed by another +-- client. Any resources specified for the background-pixmap or cursor +-- attributes may be freed immediately. The server is free to copy the +-- background-pixmap or cursor resources or to use them in place; therefore, +-- the effect of changing the contents of those resources is undefined. +-- If the specified colormap no longer exists when the screen +-- saver activates, the parent's colormap is used instead. If no errors +-- are generated by this request, any previous screen saver window +-- attributes set by this client are released. +-- +-- When the screen saver next activates and the server is not grabbed by +-- another client, the screen saver window is created, if necessary, and +-- set to the specified attributes and events are generated as usual. The +-- colormap associated with the screen saver window is installed. +-- Finally, the screen saver window is mapped. +-- +-- The window remains mapped and at the top of the stacking order until +-- the screen saver is deactivated in response to activity on any of the +-- user input devices, a ForceScreenSaver request with a value of Reset, +-- or any request that would cause the window to be unmapped. +-- +-- If the screen saver activates while the server is grabbed by another +-- client, the internal saver mechanism is used. The ForceScreenSaver +-- request may be used with a value of Active to deactivate the internal +-- saver and activate the external saver. +-- +-- If the screen saver client's connection to the server is broken while +-- the screen saver is activated and the client's close down mode has not +-- been RetainPermanent or RetainTemporary, the current screen saver is +-- deactivated and the internal screen saver is immediately activated. +-- +-- When the screen saver deactivates, the screen saver window's colormap +-- is uninstalled and the window is unmapped (except as described below). +-- The screen saver XID is disassociated with the window and the server +-- may, but is not required to, destroy the window along with any children. +-- +-- When the screen saver is being deactivated and then immediately reactivated +-- (such as when switching screen savers), the server may leave the +-- screen saver window mapped (typically to avoid generating exposures). + +xScreenSaverSetAttributes :: Display + -> Position -- ^ x + -> Position -- ^ y + -> Dimension -- ^ width + -> Dimension -- ^ height + -> Dimension -- ^ border width + -> CInt -- ^ depth ('defaultDepthOfScreen') + -> WindowClass -- ^ class + -> Visual -- ^ visual ('defaultVisualOfScreen') + -> AttributeMask -- ^ valuemask + -> Ptr SetWindowAttributes + -> IO () +xScreenSaverSetAttributes dpy x y w h bw d wc v am pswa = do + cXScreenSaverSetAttributes dpy (defaultRootWindow dpy) + x y w h bw d wc v am pswa + +-- | XScreenSaverUnsetAttributes instructs the server to discard any previ‐ +-- ous screen saver window attributes set by this client. + +xScreenSaverUnsetAttributes :: Display -> IO () +xScreenSaverUnsetAttributes dpy = + cXScreenSaverUnsetAttributes dpy (defaultRootWindow dpy) + +-- | XScreenSaverRegister stores the given XID in the _SCREEN_SAVER_ID prop‐ +-- erty (of the given type) on the root window of the specified screen. +-- It returns zero if an error is encountered and the property is not +-- changed, otherwise it returns non-zero. + +xScreenSaverSaverRegister :: Display -> ScreenNumber -> XID -> Atom -> IO () +xScreenSaverSaverRegister = cXScreenSaverSaverRegister + +-- | XScreenSaverUnregister removes any _SCREEN_SAVER_ID from the root win‐ +-- dow of the specified screen. It returns zero if an error is encoun‐ +-- tered and the property is changed, otherwise it returns non-zero. + +xScreenSaverUnregister :: Display -> ScreenNumber -> IO Status +xScreenSaverUnregister = cXScreenSaverUnregister + +-- | XScreenSaverGetRegistered returns the XID and type stored in the +-- _SCREEN_SAVER_ID property on the root window of the specified screen. +-- It returns zero if an error is encountered or if the property does not +-- exist or is not of the correct format; otherwise it returns non-zero. + +xScreenSaverGetRegistered :: Display -> ScreenNumber -> XID -> Atom -> IO Status +xScreenSaverGetRegistered = cXScreenSaverGetRegistered + +-- | XScreenSaverSuspend temporarily suspends the screensaver and DPMS timer +-- if suspend is 'True', and restarts the timer if suspend is 'False'. +-- This function should be used by applications that don't want the +-- screensaver or DPMS to become activated while they're for example in +-- the process of playing a media sequence, or are otherwise continuously +-- presenting visual information to the user while in a non-interactive +-- state. This function is not intended to be called by an external +-- screensaver application. +-- +-- If XScreenSaverSuspend is called multiple times with suspend set to +-- 'True', it must be called an equal number of times with suspend set to +-- 'False' in order for the screensaver timer to be restarted. This +-- request has no affect if a client tries to resume the screensaver with‐ +-- out first having suspended it. XScreenSaverSuspend can thus not be +-- used by one client to resume the screensaver if it's been suspended by +-- another client. +-- +-- If a client that has suspended the screensaver becomes disconnected +-- from the X server, the screensaver timer will automatically be +-- restarted, unless it's still suspended by another client. Suspending +-- the screensaver timer doesn't prevent the screensaver from being forceably +-- activated with the ForceScreenSaver request, or a DPMS mode from +-- being set with the DPMSForceLevel request. +-- +-- XScreenSaverSuspend also doesn't deactivate the screensaver or DPMS if +-- either is active at the time the request to suspend them is received by +-- the X server. But once they've been deactivated, they won't automatically +-- be activated again, until the client has canceled the suspension. + +xScreenSaverSuspend :: Display -> Bool -> IO () +xScreenSaverSuspend = cXScreenSaverSuspend + + +foreign import ccall "XScreenSaverQueryExtension" + cXScreenSaverQueryExtension :: Display -> Ptr CInt -> Ptr CInt -> IO Bool + +foreign import ccall "XScreenSaverQueryVersion" + cXScreenSaverQueryVersion :: Display -> Ptr CInt -> Ptr CInt -> IO Bool + +foreign import ccall "XScreenSaverAllocInfo" + cXScreenSaverAllocInfo :: IO (Ptr XScreenSaverInfo) + +foreign import ccall "XScreenSaverQueryInfo" + cXScreenSaverQueryInfo :: Display -> Drawable -> Ptr XScreenSaverInfo + -> IO Status + +foreign import ccall "XScreenSaverSelectInput" + cXScreenSaverSelectInput :: Display -> Drawable -> EventMask -> IO () + +foreign import ccall "XScreenSaverSetAttributes" + cXScreenSaverSetAttributes :: Display -> Drawable -> Position -> Position + -> Dimension -> Dimension -> Dimension + -> CInt + -> WindowClass + -> Visual + -> AttributeMask + -> Ptr SetWindowAttributes + -> IO () + +foreign import ccall "XScreenSaverUnsetAttributes" + cXScreenSaverUnsetAttributes :: Display -> Drawable -> IO () + +foreign import ccall "XScreenSaverRegister" + cXScreenSaverSaverRegister :: Display -> ScreenNumber -> XID -> Atom + -> IO () + +foreign import ccall "XScreenSaverUnregister" + cXScreenSaverUnregister :: Display -> ScreenNumber -> IO Status + +foreign import ccall "XScreenSaverGetRegistered" + cXScreenSaverGetRegistered :: Display -> ScreenNumber -> XID -> Atom + -> IO Status + +foreign import ccall "XScreenSaverSuspend" + cXScreenSaverSuspend :: Display -> Bool -> IO () diff --git a/Graphics/X11/Xinerama.hsc b/Graphics/X11/Xinerama.hsc --- a/Graphics/X11/Xinerama.hsc +++ b/Graphics/X11/Xinerama.hsc @@ -29,6 +29,7 @@ import Foreign.C.Types import Graphics.X11.Xlib import Graphics.X11.Xlib.Extras (WindowAttributes(..), getWindowAttributes) +import Graphics.X11.Xlib.Internal import Control.Monad -- | Representation of the XineramaScreenInfo struct @@ -68,9 +69,6 @@ compiledWithXinerama :: Bool compiledWithXinerama = True --- for XFree() (already included from Xinerama.h, but I don't know if I can count on that.) -#include - #include instance Storable XineramaScreenInfo where @@ -106,14 +104,14 @@ go True major minor = Just (fromIntegral major, fromIntegral minor) xineramaQueryScreens :: Display -> IO (Maybe [XineramaScreenInfo]) -xineramaQueryScreens dpy = +xineramaQueryScreens dpy = withPool $ \pool -> do intp <- pooledMalloc pool p <- cXineramaQueryScreens dpy intp - if p == nullPtr + if p == nullPtr then return Nothing else do nscreens <- peek intp screens <- peekArray (fromIntegral nscreens) p - cXFree p + _ <- xFree p return (Just screens) foreign import ccall "XineramaQueryExtension" @@ -124,9 +122,6 @@ foreign import ccall "XineramaQueryScreens" cXineramaQueryScreens :: Display -> Ptr CInt -> IO (Ptr XineramaScreenInfo) - -foreign import ccall "XFree" - cXFree :: Ptr a -> IO CInt wrapPtr2 :: (Storable a, Storable b) => (Ptr a -> Ptr b -> IO c) -> (c -> a -> b -> d) -> IO d wrapPtr2 cfun f = diff --git a/Graphics/X11/Xlib.hs b/Graphics/X11/Xlib.hs --- a/Graphics/X11/Xlib.hs +++ b/Graphics/X11/Xlib.hs @@ -3,7 +3,7 @@ -- Module : Graphics.X11.Xlib -- Copyright : (c) Alastair Reid, 1999-2003 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable @@ -19,18 +19,18 @@ -- ----------------------------------------------------------------------------- -module Graphics.X11.Xlib - ( -- * Conventions - -- $conventions +module Graphics.X11.Xlib + ( -- * Conventions + -- $conventions - -- * Types - module Graphics.X11.Types, + -- * Types + module Graphics.X11.Types, -- module Graphics.X11.Xlib.Types, - Display(..), Screen, Visual, GC, SetWindowAttributes, - Point(..), Rectangle(..), Arc(..), Segment(..), Color(..), - Pixel, Position, Dimension, Angle, ScreenNumber, Buffer, + Display(..), Screen, Visual, GC, SetWindowAttributes, VisualInfo(..), + Point(..), Rectangle(..), Arc(..), Segment(..), Color(..), + Pixel, Position, Dimension, Angle, ScreenNumber, Buffer, - -- * X11 library functions + -- * X11 library functions module Graphics.X11.Xlib.Event, module Graphics.X11.Xlib.Display, module Graphics.X11.Xlib.Screen, @@ -43,8 +43,8 @@ module Graphics.X11.Xlib.Region, module Graphics.X11.Xlib.Image, module Graphics.X11.Xlib.Misc, - - ) where + + ) where import Graphics.X11.Types import Graphics.X11.Xlib.Types diff --git a/Graphics/X11/Xlib/Atom.hsc b/Graphics/X11/Xlib/Atom.hsc --- a/Graphics/X11/Xlib/Atom.hsc +++ b/Graphics/X11/Xlib/Atom.hsc @@ -14,6 +14,8 @@ module Graphics.X11.Xlib.Atom( internAtom, + getAtomName, + getAtomNames, pRIMARY, sECONDARY, @@ -88,8 +90,11 @@ ) where import Graphics.X11.Types +import Graphics.X11.Xlib.Internal import Graphics.X11.Xlib.Types +import Foreign hiding ( void ) +import Foreign.C.Types import Foreign.C.String #include "HsXlib.h" @@ -108,9 +113,37 @@ foreign import ccall unsafe "XInternAtom" xInternAtom :: Display -> CString -> Bool -> IO Atom --- XInternAtoms omitted --- XGetAtomName omitted --- XGetAtomNames omitted +-- jrk, 22.11.2012: getAtomName{,s} + +getAtomName :: Display -> Atom -> IO (Maybe String) +getAtomName dpy atom = do + p <- cXGetAtomName dpy atom + if p == nullPtr + then return Nothing + else do + res <- peekCString p + _ <- xFree p + return $ Just res + +foreign import ccall "XGetAtomName" + cXGetAtomName :: Display -> Atom -> IO (Ptr CChar) + +getAtomNames :: Display -> [Atom] -> IO [String] +getAtomNames dpy atoms = withPool $ \pool -> do + atomsp <- (pooledMallocArray pool $ length atoms) :: IO (Ptr Atom) + ccharp <- (pooledMallocArray pool $ length atoms) :: IO (Ptr (Ptr CChar)) + + pokeArray atomsp atoms + _ <- cXGetAtomNames dpy atomsp (fromIntegral $ length atoms :: CInt) ccharp + + res <- peekArray (length atoms) ccharp >>= mapM peekCString + peekArray (length atoms) ccharp >>= mapM_ xFree + + return res + +foreign import ccall "XGetAtomNames" + cXGetAtomNames :: Display -> Ptr Atom -> CInt -> Ptr (Ptr CChar) -> IO Status + -- XConvertSelection omitted -- XListProperties omitted -- XChangeProperty omitted diff --git a/Graphics/X11/Xlib/Color.hs b/Graphics/X11/Xlib/Color.hs --- a/Graphics/X11/Xlib/Color.hs +++ b/Graphics/X11/Xlib/Color.hs @@ -35,7 +35,6 @@ import Foreign import Foreign.C -import Foreign.C.Types ---------------------------------------------------------------- -- Color and Colormaps diff --git a/Graphics/X11/Xlib/Context.hs b/Graphics/X11/Xlib/Context.hs --- a/Graphics/X11/Xlib/Context.hs +++ b/Graphics/X11/Xlib/Context.hs @@ -46,7 +46,6 @@ import Foreign import Foreign.C -import Foreign.C.Types ---------------------------------------------------------------- -- Graphics contexts diff --git a/Graphics/X11/Xlib/Display.hs b/Graphics/X11/Xlib/Display.hs --- a/Graphics/X11/Xlib/Display.hs +++ b/Graphics/X11/Xlib/Display.hs @@ -53,8 +53,10 @@ import Graphics.X11.Types import Graphics.X11.Xlib.Types -import Foreign +import Foreign (throwIfNull, Ptr) import Foreign.C + +import System.IO.Unsafe ---------------------------------------------------------------- -- Display diff --git a/Graphics/X11/Xlib/Event.hsc b/Graphics/X11/Xlib/Event.hsc --- a/Graphics/X11/Xlib/Event.hsc +++ b/Graphics/X11/Xlib/Event.hsc @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.X11.Xlib.Event @@ -18,7 +18,7 @@ queuedAlready, queuedAfterFlush, queuedAfterReading, - XEvent, + XEvent(..), XEventPtr, allocaXEvent, get_EventType, @@ -67,7 +67,7 @@ import Foreign.C.Types #if __GLASGOW_HASKELL__ -import Data.Generics +import Data.Data #endif #include "HsXlib.h" @@ -388,6 +388,7 @@ -- -- getSelectionClearEvent omitted -- -- getSelectionRequestEvent omitted -- -- getSelectionEvent omitted +-- -- xrrScreenChangeNotifyEvent omitted -- functions @@ -493,7 +494,7 @@ XEventPtr -> IO Status -- | interface to the X11 library function @XWindowEvent()@. -foreign import ccall unsafe "HsXlib.h XWindowEvent" +foreign import ccall safe "HsXlib.h XWindowEvent" windowEvent :: Display -> Window -> EventMask -> XEventPtr -> IO () -- | interface to the X11 library function @XCheckWindowEvent()@. @@ -502,7 +503,7 @@ XEventPtr -> IO Bool -- | interface to the X11 library function @XMaskEvent()@. -foreign import ccall unsafe "HsXlib.h XMaskEvent" +foreign import ccall safe "HsXlib.h XMaskEvent" maskEvent :: Display -> EventMask -> XEventPtr -> IO () -- | interface to the X11 library function @XCheckMaskEvent()@. @@ -523,7 +524,7 @@ putBackEvent :: Display -> XEventPtr -> IO () -- | interface to the X11 library function @XPeekEvent()@. -foreign import ccall unsafe "HsXlib.h XPeekEvent" +foreign import ccall safe "HsXlib.h XPeekEvent" peekEvent :: Display -> XEventPtr -> IO () -- XFilterEvent omitted (can't find documentation) diff --git a/Graphics/X11/Xlib/Extras.hsc b/Graphics/X11/Xlib/Extras.hsc --- a/Graphics/X11/Xlib/Extras.hsc +++ b/Graphics/X11/Xlib/Extras.hsc @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts -fno-warn-name-shadowing #-} +{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.X11.Xlib.Extras @@ -11,17 +11,25 @@ -- missing functionality from the X11 library -- -module Graphics.X11.Xlib.Extras where +module Graphics.X11.Xlib.Extras ( + module Graphics.X11.Xlib.Extras, + module Graphics.X11.Xlib.Internal + ) where +import Data.Maybe import Data.Typeable ( Typeable ) +import Graphics.X11.Xrandr +import Graphics.X11.XScreenSaver import Graphics.X11.Xlib +import Graphics.X11.Xlib.Internal import Graphics.X11.Xlib.Types -import Graphics.X11.Xlib.Misc -import Foreign +import Foreign (Storable, Ptr, peek, poke, pokeArray, peekElemOff, peekByteOff, pokeByteOff, peekArray, throwIfNull, nullPtr, sizeOf, alignment, alloca, with, throwIf, Word8, Word16, #{type unsigned long}, Int32, plusPtr, castPtr, withArrayLen, setBit, testBit, allocaBytes, FunPtr) import Foreign.C.Types import Foreign.C.String import Control.Monad +import System.IO.Unsafe + #include "XlibExtras.h" data Event @@ -181,6 +189,15 @@ , ev_property :: !Atom , ev_time :: !Time } + | SelectionClear + { ev_event_type :: !EventType + , ev_serial :: !CULong + , ev_send_event :: !Bool + , ev_event_display :: Display + , ev_window :: !Window + , ev_selection :: !Atom + , ev_time :: !Time + } | PropertyEvent { ev_event_type :: !EventType , ev_serial :: !CULong @@ -203,6 +220,15 @@ , ev_height :: !CInt , ev_count :: !CInt } + | FocusChangeEvent + { ev_event_type :: !EventType + , ev_serial :: !CULong + , ev_send_event :: !Bool + , ev_event_display :: Display + , ev_window :: !Window + , ev_mode :: !NotifyMode + , ev_detail :: !NotifyDetail + } | ClientMessageEvent { ev_event_type :: !EventType , ev_serial :: !CULong @@ -212,7 +238,84 @@ , ev_message_type :: !Atom , ev_data :: ![CInt] } - + | RRScreenChangeNotifyEvent + { ev_event_type :: !EventType + , ev_serial :: !CULong + , ev_send_event :: !Bool + , ev_event_display :: Display + , ev_window :: !Window + , ev_root :: !Window + , ev_timestamp :: !Time + , ev_config_timestamp :: !Time + , ev_size_index :: !SizeID + , ev_subpixel_order :: !SubpixelOrder + , ev_rotation :: !Rotation + , ev_width :: !CInt + , ev_height :: !CInt + , ev_mwidth :: !CInt + , ev_mheight :: !CInt + } + | RRNotifyEvent + { ev_event_type :: !EventType + , ev_serial :: !CULong + , ev_send_event :: !Bool + , ev_event_display :: Display + , ev_window :: !Window + , ev_subtype :: !CInt + } + | RRCrtcChangeNotifyEvent + { ev_event_type :: !EventType + , ev_serial :: !CULong + , ev_send_event :: !Bool + , ev_event_display :: Display + , ev_window :: !Window + , ev_subtype :: !CInt + , ev_crtc :: !RRCrtc + , ev_rr_mode :: !RRMode + , ev_rotation :: !Rotation + , ev_x :: !CInt + , ev_y :: !CInt + , ev_rr_width :: !CUInt + , ev_rr_height :: !CUInt + } + | RROutputChangeNotifyEvent + { ev_event_type :: !EventType + , ev_serial :: !CULong + , ev_send_event :: !Bool + , ev_event_display :: Display + , ev_window :: !Window + , ev_subtype :: !CInt + , ev_output :: !RROutput + , ev_crtc :: !RRCrtc + , ev_rr_mode :: !RRMode + , ev_rotation :: !Rotation + , ev_connection :: !Connection + , ev_subpixel_order :: !SubpixelOrder + } + | RROutputPropertyNotifyEvent + { ev_event_type :: !EventType + , ev_serial :: !CULong + , ev_send_event :: !Bool + , ev_event_display :: Display + , ev_window :: !Window + , ev_subtype :: !CInt + , ev_output :: !RROutput + , ev_property :: !Atom + , ev_timestamp :: !Time + , ev_rr_state :: !CInt + } + | ScreenSaverNotifyEvent + { ev_event_type :: !EventType + , ev_serial :: !CULong + , ev_send_event :: !Bool + , ev_event_display :: Display + , ev_window :: !Window + , ev_root :: !Window + , ev_ss_state :: !XScreenSaverState + , ev_ss_kind :: !XScreenSaverKind + , ev_forced :: !Bool + , ev_time :: !Time + } deriving ( Show, Typeable ) eventTable :: [(EventType, String)] @@ -251,6 +354,7 @@ , (clientMessage , "ClientMessage") , (mappingNotify , "MappingNotify") , (lASTEvent , "LASTEvent") + , (screenSaverNotify , "ScreenSaverNotify") ] eventName :: Event -> String @@ -265,6 +369,9 @@ serial <- #{peek XAnyEvent, serial} p send_event <- #{peek XAnyEvent, send_event} p display <- fmap Display (#{peek XAnyEvent, display} p) + rrData <- xrrQueryExtension display + let rrHasExtension = isJust rrData + let rrEventBase = fromIntegral $ fst $ fromMaybe (0, 0) rrData case () of ------------------------- @@ -546,6 +653,22 @@ } ------------------------- + -- SelectionClearEvent: + ------------------------- + | type_ == selectionClear -> do + window <- #{peek XSelectionClearEvent, window } p + atom <- #{peek XSelectionClearEvent, selection } p + time <- #{peek XSelectionClearEvent, time } p + return $ SelectionClear + { ev_event_type = type_ + , ev_serial = serial + , ev_send_event = send_event + , ev_event_display = display + , ev_window = window + , ev_selection = atom + , ev_time = time + } + ------------------------- -- PropertyEvent ------------------------- | type_ == propertyNotify -> do @@ -588,6 +711,23 @@ } ------------------------- + -- FocusChangeEvent + ------------------------- + | type_ == focusIn || type_ == focusOut -> do + window <- #{peek XFocusChangeEvent, window } p + mode <- #{peek XFocusChangeEvent, mode } p + detail <- #{peek XFocusChangeEvent, detail } p + return $ FocusChangeEvent + { ev_event_type = type_ + , ev_serial = serial + , ev_send_event = send_event + , ev_event_display = display + , ev_window = window + , ev_mode = mode + , ev_detail = detail + } + + ------------------------- -- ClientMessageEvent ------------------------- | type_ == clientMessage -> do @@ -601,7 +741,7 @@ 16 -> do a <- peekArray 10 datPtr return $ map fromIntegral (a::[Word16]) 32 -> do a <- peekArray 5 datPtr - return $ map fromIntegral (a::[Word32]) + return $ map fromIntegral (a::[CLong]) _ -> error "X11.Extras.clientMessage: illegal value" return $ ClientMessageEvent { ev_event_type = type_ @@ -613,6 +753,137 @@ , ev_data = dat } + ------------------------- + -- RRScreenChangeNotify + ------------------------- + | rrHasExtension && + type_ == rrEventBase + rrScreenChangeNotify -> do + window <- #{peek XRRScreenChangeNotifyEvent, window } p + root <- #{peek XRRScreenChangeNotifyEvent, root } p + timestamp <- #{peek XRRScreenChangeNotifyEvent, timestamp } p + config_timestamp <- #{peek XRRScreenChangeNotifyEvent, config_timestamp } p + size_index <- #{peek XRRScreenChangeNotifyEvent, config_timestamp } p + subpixel_order <- #{peek XRRScreenChangeNotifyEvent, subpixel_order } p + rotation <- #{peek XRRScreenChangeNotifyEvent, rotation } p + width <- #{peek XRRScreenChangeNotifyEvent, width } p + height <- #{peek XRRScreenChangeNotifyEvent, height } p + mwidth <- #{peek XRRScreenChangeNotifyEvent, mwidth } p + mheight <- #{peek XRRScreenChangeNotifyEvent, mheight } p + return $ RRScreenChangeNotifyEvent + { ev_event_type = type_ + , ev_serial = serial + , ev_send_event = send_event + , ev_event_display = display + , ev_window = window + , ev_root = root + , ev_timestamp = timestamp + , ev_config_timestamp = config_timestamp + , ev_size_index = size_index + , ev_subpixel_order = subpixel_order + , ev_rotation = rotation + , ev_width = width + , ev_height = height + , ev_mwidth = mwidth + , ev_mheight = mheight + } + + ------------------------- + -- RRNotify + ------------------------- + | rrHasExtension && + type_ == rrEventBase + rrNotify -> do + window <- #{peek XRRNotifyEvent, window } p + subtype <- #{peek XRRNotifyEvent, subtype } p + let subtype_ = fromIntegral subtype + case () of + _ | subtype_ == rrNotifyCrtcChange -> do + crtc <- #{peek XRRCrtcChangeNotifyEvent, crtc } p + mode <- #{peek XRRCrtcChangeNotifyEvent, mode } p + rotation <- #{peek XRRCrtcChangeNotifyEvent, rotation } p + x <- #{peek XRRCrtcChangeNotifyEvent, x } p + y <- #{peek XRRCrtcChangeNotifyEvent, y } p + width <- #{peek XRRCrtcChangeNotifyEvent, width } p + height <- #{peek XRRCrtcChangeNotifyEvent, height } p + return $ RRCrtcChangeNotifyEvent + { ev_event_type = type_ + , ev_serial = serial + , ev_send_event = send_event + , ev_event_display = display + , ev_window = window + , ev_subtype = subtype + , ev_crtc = crtc + , ev_rr_mode = mode + , ev_rotation = rotation + , ev_x = x + , ev_y = y + , ev_rr_width = width + , ev_rr_height = height + } + + | subtype_ == rrNotifyOutputChange -> do + output <- #{peek XRROutputChangeNotifyEvent, output } p + crtc <- #{peek XRROutputChangeNotifyEvent, crtc } p + mode <- #{peek XRROutputChangeNotifyEvent, mode } p + rotation <- #{peek XRROutputChangeNotifyEvent, rotation } p + connection <- #{peek XRROutputChangeNotifyEvent, connection } p + subpixel_order <- #{peek XRROutputChangeNotifyEvent, subpixel_order } p + return $ RROutputChangeNotifyEvent + { ev_event_type = type_ + , ev_serial = serial + , ev_send_event = send_event + , ev_event_display = display + , ev_window = window + , ev_subtype = subtype + , ev_output = output + , ev_crtc = crtc + , ev_rr_mode = mode + , ev_rotation = rotation + , ev_connection = connection + , ev_subpixel_order = subpixel_order + } + + | subtype_ == rrNotifyOutputProperty -> do + output <- #{peek XRROutputPropertyNotifyEvent, output } p + property <- #{peek XRROutputPropertyNotifyEvent, property } p + timestamp <- #{peek XRROutputPropertyNotifyEvent, timestamp } p + state <- #{peek XRROutputPropertyNotifyEvent, state } p + return $ RROutputPropertyNotifyEvent + { ev_event_type = type_ + , ev_serial = serial + , ev_send_event = send_event + , ev_event_display = display + , ev_window = window + , ev_subtype = subtype + , ev_output = output + , ev_property = property + , ev_timestamp = timestamp + , ev_rr_state = state + } + + -- We don't handle this event specifically, so return the generic + -- RRNotifyEvent. + | otherwise -> do + return $ RRNotifyEvent + { ev_event_type = type_ + , ev_serial = serial + , ev_send_event = send_event + , ev_event_display = display + , ev_window = window + , ev_subtype = subtype + } + + ----------------- + -- ScreenSaverNotifyEvent: + ----------------- + | type_ == screenSaverNotify -> do + return (ScreenSaverNotifyEvent type_ serial send_event display) + `ap` (#{peek XScreenSaverNotifyEvent, window } p ) + `ap` (#{peek XScreenSaverNotifyEvent, root } p ) + `ap` (#{peek XScreenSaverNotifyEvent, state } p ) + `ap` (#{peek XScreenSaverNotifyEvent, kind } p ) + `ap` (#{peek XScreenSaverNotifyEvent, forced } p ) + `ap` (#{peek XScreenSaverNotifyEvent, time } p ) + -- We don't handle this event specifically, so return the generic -- AnyEvent. | otherwise -> do @@ -649,7 +920,7 @@ #{poke XWindowChanges, border_width} p $ wc_border_width wc #{poke XWindowChanges, sibling } p $ wc_sibling wc #{poke XWindowChanges, stack_mode } p $ wc_stack_mode wc - + peek p = return WindowChanges `ap` (#{peek XWindowChanges, x} p) `ap` (#{peek XWindowChanges, y} p) @@ -687,12 +958,9 @@ configureWindow :: Display -> Window -> CULong -> WindowChanges -> IO () configureWindow d w m c = do - with c (xConfigureWindow d w m) + _ <- with c (xConfigureWindow d w m) return () -foreign import ccall unsafe "XlibExtras.h XFree" - xFree :: Ptr a -> IO CInt - foreign import ccall unsafe "XlibExtras.h XQueryTree" xQueryTree :: Display -> Window -> Ptr Window -> Ptr Window -> Ptr (Ptr Window) -> Ptr CInt -> IO Status @@ -702,21 +970,26 @@ alloca $ \parent_return -> alloca $ \children_return -> alloca $ \nchildren_return -> do - xQueryTree d w root_return parent_return children_return nchildren_return + _ <- throwIfZero "queryTree" $ xQueryTree d w root_return parent_return children_return nchildren_return p <- peek children_return n <- fmap fromIntegral $ peek nchildren_return ws <- peekArray n p - xFree p + _ <- xFree p liftM3 (,,) (peek root_return) (peek parent_return) (return ws) -- TODO: this data type is incomplete wrt. the C struct data WindowAttributes = WindowAttributes { wa_x, wa_y, wa_width, wa_height, wa_border_width :: CInt + , wa_colormap :: Colormap + , wa_map_installed :: Bool , wa_map_state :: CInt + , wa_all_event_masks :: EventMask + , wa_your_event_mask :: EventMask + , wa_do_not_propagate_mask :: EventMask , wa_override_redirect :: Bool } --- +-- -- possible map_states' -- waIsUnmapped, waIsUnviewable, waIsViewable :: CInt @@ -734,7 +1007,12 @@ `ap` (#{peek XWindowAttributes, width } p) `ap` (#{peek XWindowAttributes, height } p) `ap` (#{peek XWindowAttributes, border_width } p) + `ap` (#{peek XWindowAttributes, colormap } p) + `ap` (#{peek XWindowAttributes, map_installed } p) `ap` (#{peek XWindowAttributes, map_state } p) + `ap` (#{peek XWindowAttributes, all_event_masks } p) + `ap` (#{peek XWindowAttributes, your_event_mask } p) + `ap` (#{peek XWindowAttributes, do_not_propagate_mask } p) `ap` (#{peek XWindowAttributes, override_redirect} p) poke p wa = do #{poke XWindowAttributes, x } p $ wa_x wa @@ -742,7 +1020,12 @@ #{poke XWindowAttributes, width } p $ wa_width wa #{poke XWindowAttributes, height } p $ wa_height wa #{poke XWindowAttributes, border_width } p $ wa_border_width wa + #{poke XWindowAttributes, colormap } p $ wa_colormap wa + #{poke XWindowAttributes, map_installed } p $ wa_map_installed wa #{poke XWindowAttributes, map_state } p $ wa_map_state wa + #{poke XWindowAttributes, all_event_masks } p $ wa_all_event_masks wa + #{poke XWindowAttributes, your_event_mask } p $ wa_your_event_mask wa + #{poke XWindowAttributes, do_not_propagate_mask } p $ wa_do_not_propagate_mask wa #{poke XWindowAttributes, override_redirect} p $ wa_override_redirect wa foreign import ccall unsafe "XlibExtras.h XGetWindowAttributes" @@ -750,7 +1033,7 @@ getWindowAttributes :: Display -> Window -> IO WindowAttributes getWindowAttributes d w = alloca $ \p -> do - xGetWindowAttributes d w p + _ <- throwIfZero "getWindowAttributes" $ xGetWindowAttributes d w p peek p -- | interface to the X11 library function @XChangeWindowAttributes()@. @@ -790,7 +1073,7 @@ getTextProperty :: Display -> Window -> Atom -> IO TextProperty getTextProperty d w a = alloca $ \textp -> do - throwIf (0==) (const "getTextProperty") $ xGetTextProperty d w textp a + _ <- throwIf (0==) (const "getTextProperty") $ xGetTextProperty d w textp a peek textp foreign import ccall unsafe "XlibExtras.h XwcTextPropertyToTextList" @@ -801,7 +1084,7 @@ alloca $ \listp -> alloca $ \countp -> with prop $ \propp -> do - throwIf (success>) (const "wcTextPropertyToTextList") $ + _ <- throwIf (success>) (const "wcTextPropertyToTextList") $ xwcTextPropertyToTextList d propp listp countp count <- peek countp list <- peek listp @@ -849,7 +1132,7 @@ withCWStringLen text $ \(textp, len) -> alloca $ \inkp -> alloca $ \logicalp -> do - xwcTextExtents fs textp (fromIntegral len) inkp logicalp + _ <- xwcTextExtents fs textp (fromIntegral len) inkp logicalp (,) `fmap` peek inkp `ap` peek logicalp foreign import ccall unsafe "XlibExtras.h XwcDrawString" @@ -881,13 +1164,13 @@ fetchName :: Display -> Window -> IO (Maybe String) fetchName d w = alloca $ \p -> do - xFetchName d w p + _ <- xFetchName d w p cstr <- peek p if cstr == nullPtr then return Nothing else do str <- peekCString cstr - xFree cstr + _ <- xFree cstr return $ Just str foreign import ccall unsafe "XlibExtras.h XGetTransientForHint" @@ -935,7 +1218,7 @@ else do sz <- peek count_ptr atom_ptr <- peek atom_ptr_ptr atoms <- peekArray (fromIntegral sz) atom_ptr - xFree atom_ptr + _ <- xFree atom_ptr return atoms foreign import ccall unsafe "HsXlib.h XGetWMProtocols" @@ -975,14 +1258,22 @@ -- Should have a Storable instance for XEvent/Event? setClientMessageEvent :: XEventPtr -> Window -> Atom -> CInt -> Atom -> Time -> IO () setClientMessageEvent p window message_type format l_0_ l_1_ = do + setClientMessageEvent' p window message_type format [fromIntegral l_0_, fromIntegral l_1_] + +-- slightly less hacky way to set up an XClientMessageEvent +setClientMessageEvent' :: XEventPtr -> Window -> Atom -> CInt -> [CInt] -> IO () +setClientMessageEvent' p window message_type format dat = do #{poke XClientMessageEvent, window} p window #{poke XClientMessageEvent, message_type} p message_type #{poke XClientMessageEvent, format} p format - let datap = #{ptr XClientMessageEvent, data} p :: Ptr CLong - poke datap (fromIntegral l_0_) -- does this work? - pokeElemOff datap 1 (fromIntegral l_1_) - - return () + case format of + 8 -> do let datap = #{ptr XClientMessageEvent, data} p :: Ptr Word8 + pokeArray datap $ take 20 $ map fromIntegral dat ++ repeat 0 + 16 -> do let datap = #{ptr XClientMessageEvent, data} p :: Ptr Word16 + pokeArray datap $ take 10 $ map fromIntegral dat ++ repeat 0 + 32 -> do let datap = #{ptr XClientMessageEvent, data} p :: Ptr CLong + pokeArray datap $ take 5 $ map fromIntegral dat ++ repeat 0 + _ -> error "X11.Extras.setClientMessageEvent': illegal format" setConfigureEvent :: XEventPtr -> Window -> Window -> CInt -> CInt -> CInt -> CInt -> CInt -> Window -> Bool -> IO () setConfigureEvent p ev win x y w h bw abv org = do @@ -1031,7 +1322,7 @@ ------------------------------------------------------------------------ -- XErrorEvents --- +-- -- I'm too lazy to write the binding -- @@ -1051,7 +1342,7 @@ #{poke XMappingEvent, request } p $ ev_request ev #{poke XMappingEvent, first_keycode } p $ ev_first_keycode ev #{poke XMappingEvent, count } p $ ev_count ev - xRefreshKeyboardMapping p + _ <- xRefreshKeyboardMapping p return () refreshKeyboardMapping _ = return () @@ -1066,6 +1357,9 @@ foreign import ccall unsafe "XlibExtras.h XChangeProperty" xChangeProperty :: Display -> Window -> Atom -> Atom -> CInt -> CInt -> Ptr CUChar -> CInt -> IO Status +foreign import ccall unsafe "XlibExtras.h XDeleteProperty" + xDeleteProperty :: Display -> Window -> Atom -> IO Status + foreign import ccall unsafe "XlibExtras.h XGetWindowProperty" xGetWindowProperty :: Display -> Window -> Atom -> CLong -> CLong -> Bool -> Atom -> Ptr Atom -> Ptr CInt -> Ptr CULong -> Ptr CULong -> Ptr (Ptr CUChar) -> IO Status @@ -1096,7 +1390,7 @@ | actual_format /= bits = xFree prop_ptr >> return Nothing | otherwise = do retval <- peekArray nitems (castPtr prop_ptr) - xFree prop_ptr + _ <- xFree prop_ptr return $ Just retval getWindowProperty8 :: Display -> Atom -> Window -> IO (Maybe [CChar]) @@ -1113,19 +1407,19 @@ changeProperty8 :: Display -> Window -> Atom -> Atom -> CInt -> [CChar] -> IO () changeProperty8 dpy w prop typ mode dat = withArrayLen dat $ \ len ptr -> do - xChangeProperty dpy w prop typ 8 mode (castPtr ptr) (fromIntegral len) + _ <- xChangeProperty dpy w prop typ 8 mode (castPtr ptr) (fromIntegral len) return () changeProperty16 :: Display -> Window -> Atom -> Atom -> CInt -> [CShort] -> IO () changeProperty16 dpy w prop typ mode dat = withArrayLen dat $ \ len ptr -> do - xChangeProperty dpy w prop typ 16 mode (castPtr ptr) (fromIntegral len) + _ <- xChangeProperty dpy w prop typ 16 mode (castPtr ptr) (fromIntegral len) return () changeProperty32 :: Display -> Window -> Atom -> Atom -> CInt -> [CLong] -> IO () changeProperty32 dpy w prop typ mode dat = withArrayLen dat $ \ len ptr -> do - xChangeProperty dpy w prop typ 32 mode (castPtr ptr) (fromIntegral len) + _ <- xChangeProperty dpy w prop typ 32 mode (castPtr ptr) (fromIntegral len) return () propModeReplace, propModePrepend, propModeAppend :: CInt @@ -1133,6 +1427,11 @@ propModePrepend = #{const PropModePrepend} propModeAppend = #{const PropModeAppend} +deleteProperty :: Display -> Window -> Atom -> IO () +deleteProperty dpy w prop = do + _ <- xDeleteProperty dpy w prop + return () + -- Windows foreign import ccall unsafe "XlibExtras.h XUnmapWindow" @@ -1224,10 +1523,25 @@ = alloca $ \sh -> do alloca $ \supplied_return -> do -- what's the purpose of supplied_return? - xGetWMNormalHints d w sh supplied_return - peek sh + status <- xGetWMNormalHints d w sh supplied_return + case status of + 0 -> return (SizeHints Nothing Nothing Nothing Nothing Nothing Nothing) + _ -> peek sh +foreign import ccall "XlibExtras.h XAllocSizeHints" + xAllocSizeHints :: IO (Ptr SizeHints) +foreign import ccall unsafe "XlibExtras.h XSetWMNormalHints" + xSetWMNormalHints :: Display -> Window -> Ptr SizeHints -> IO () + +setWMNormalHints :: Display -> Window -> SizeHints -> IO () +setWMNormalHints dpy win hints = do + ptr_hints <- throwIfNull "xAllocSizeHints" xAllocSizeHints + poke ptr_hints hints + xSetWMNormalHints dpy win ptr_hints + _ <- xFree ptr_hints + return () + data ClassHint = ClassHint { resName :: String , resClass :: String @@ -1241,14 +1555,26 @@ res_name_p <- #{peek XClassHint, res_name} p res_class_p <- #{peek XClassHint, res_class} p res <- liftM2 ClassHint (peekCString res_name_p) (peekCString res_class_p) - xFree res_name_p - xFree res_class_p + _ <- xFree res_name_p + _ <- xFree res_class_p return res else return $ ClassHint "" "" foreign import ccall unsafe "XlibExtras.h XGetClassHint" xGetClassHint :: Display -> Window -> Ptr ClassHint -> IO Status +-- | Set the @WM_CLASS@ property for the given window. +setClassHint :: Display -> Window -> ClassHint -> IO () +setClassHint dpy win (ClassHint name cl) = + allocaBytes (#{size XClassHint}) $ \ptr -> do + withCString name $ \c_name -> withCString cl $ \c_cl -> do + #{poke XClassHint, res_name } ptr c_name + #{poke XClassHint, res_class} ptr c_cl + xSetClassHint dpy win ptr + +foreign import ccall unsafe "XlibExtras.h XSetClassHint" + xSetClassHint :: Display -> Window -> Ptr ClassHint -> IO () + ------------------------------------------------------------------------ -- WM Hints @@ -1324,7 +1650,7 @@ p <- xGetWMHints dpy w if p == nullPtr then return $ WMHints 0 False 0 0 0 0 0 0 0 - else do x <- peek p; xFree p; return x + else do x <- peek p; _ <- xFree p; return x foreign import ccall unsafe "XlibExtras.h XAllocWMHints" xAllocWMHints :: IO (Ptr WMHints) @@ -1337,7 +1663,7 @@ p_wmh <- xAllocWMHints poke p_wmh wmh res <- xSetWMHints dpy w p_wmh - xFree p_wmh + _ <- xFree p_wmh return res ------------------------------------------------------------------------ @@ -1403,7 +1729,7 @@ setErrorHandler :: XErrorHandler -> IO () setErrorHandler new_handler = do _handler <- mkXErrorHandler (\d -> \e -> new_handler d e >> return 0) - _xSetErrorHandler _handler + _ <- _xSetErrorHandler _handler return () -- |Retrieves error event data from a pointer to an XErrorEvent and @@ -1441,7 +1767,7 @@ alloca $ \argcp -> do - throwIf (success >) (\status -> "xGetCommand returned status: " ++ show status) $ xGetCommand d w argvp argcp + _ <- throwIf (success >) (\status -> "xGetCommand returned status: " ++ show status) $ xGetCommand d w argvp argcp argc <- peek argcp argv <- peek argvp texts <- flip mapM [0 .. fromIntegral $ pred argc] $ \i -> peekElemOff argv i >>= peekCWString @@ -1461,7 +1787,7 @@ let m = fromIntegral m' pks <- #{peek XModifierKeymap, modifiermap} p :: IO (Ptr KeyCode) ks <- peekArray (m * 8) pks - xFreeModifiermap p + _ <- xFreeModifiermap p return . zip masks . map fst . tail . iterate (splitAt m . snd) $ ([], ks) where masks = [shiftMapIndex .. mod5MapIndex] diff --git a/Graphics/X11/Xlib/Font.hsc b/Graphics/X11/Xlib/Font.hsc --- a/Graphics/X11/Xlib/Font.hsc +++ b/Graphics/X11/Xlib/Font.hsc @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.X11.Xlib.Font @@ -20,7 +20,7 @@ fontFromGC, loadQueryFont, freeFont, - FontStruct, + FontStruct, fontFromFontStruct, ascentFromFontStruct, descentFromFontStruct, @@ -35,11 +35,13 @@ import Graphics.X11.Types import Graphics.X11.Xlib.Types -import Foreign +import Foreign (Ptr, Int32, alloca, allocaBytes, peekByteOff, Word16, #{type unsigned long}, peek, throwIfNull) import Foreign.C +import System.IO.Unsafe + #if __GLASGOW_HASKELL__ -import Data.Generics +import Data.Data #endif ---------------------------------------------------------------- @@ -53,9 +55,9 @@ -- | pointer to an X11 @XFontStruct@ structure newtype FontStruct = FontStruct (Ptr FontStruct) #if __GLASGOW_HASKELL__ - deriving (Eq, Ord, Show, Typeable, Data) + deriving (Eq, Ord, Show, Typeable, Data) #else - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show) #endif -- Disnae exist: %fun LoadFont :: Display -> String -> IO Font @@ -68,7 +70,7 @@ -- | interface to the X11 library function @XQueryFont()@. foreign import ccall unsafe "HsXlib.h XQueryFont" - queryFont :: Display -> Font -> IO FontStruct + queryFont :: Display -> Font -> IO FontStruct -- Note that this _WILL NOT WORK_ unless you have explicitly set the font. -- I'm slowly but surely coming to the conclusion that Xlib is a pile of @@ -77,40 +79,40 @@ -- | interface to the X11 library function @XGetGCValues()@. fontFromGC :: Display -> GC -> IO Font fontFromGC display gc = - allocaBytes #{size XGCValues} $ \ values -> do - throwIfZero "fontFromGC" $ - xGetGCValues display gc #{const GCFont} values - #{peek XGCValues,font} values + allocaBytes #{size XGCValues} $ \ values -> do + throwIfZero "fontFromGC" $ + xGetGCValues display gc #{const GCFont} values + #{peek XGCValues,font} values foreign import ccall unsafe "HsXlib.h XGetGCValues" - xGetGCValues :: Display -> GC -> ValueMask -> Ptr GCValues -> IO CInt + xGetGCValues :: Display -> GC -> ValueMask -> Ptr GCValues -> IO CInt type ValueMask = #{type unsigned long} -- | interface to the X11 library function @XLoadQueryFont()@. loadQueryFont :: Display -> String -> IO FontStruct loadQueryFont display name = - withCString name $ \ c_name -> do - fs <- throwIfNull "loadQueryFont" $ xLoadQueryFont display c_name - return (FontStruct fs) + withCString name $ \ c_name -> do + fs <- throwIfNull "loadQueryFont" $ xLoadQueryFont display c_name + return (FontStruct fs) foreign import ccall unsafe "HsXlib.h XLoadQueryFont" - xLoadQueryFont :: Display -> CString -> IO (Ptr FontStruct) + xLoadQueryFont :: Display -> CString -> IO (Ptr FontStruct) -- | interface to the X11 library function @XFreeFont()@. foreign import ccall unsafe "HsXlib.h XFreeFont" - freeFont :: Display -> FontStruct -> IO () + freeFont :: Display -> FontStruct -> IO () -- %fun XSetFontPath :: Display -> ListString -> IO () using XSetFontPath(arg1,arg2,arg2_size) fontFromFontStruct :: FontStruct -> Font fontFromFontStruct (FontStruct fs) = unsafePerformIO $ - #{peek XFontStruct,fid} fs + #{peek XFontStruct,fid} fs ascentFromFontStruct :: FontStruct -> Int32 ascentFromFontStruct (FontStruct fs) = unsafePerformIO $ - #{peek XFontStruct,ascent} fs + #{peek XFontStruct,ascent} fs descentFromFontStruct :: FontStruct -> Int32 descentFromFontStruct (FontStruct fs) = unsafePerformIO $ - #{peek XFontStruct,descent} fs + #{peek XFontStruct,descent} fs -- %prim XGetFontPath :: Display -> IO ListString --Int r_size; @@ -133,58 +135,58 @@ -- We marshall this across right away because it's usually one-off info type CharStruct = - ( CInt -- lbearing (origin to left edge of raster) - , CInt -- rbearing (origin to right edge of raster) - , CInt -- width (advance to next char's origin) - , CInt -- ascent (baseline to top edge of raster) - , CInt -- descent (baseline to bottom edge of raster) - -- attributes omitted - ) + ( CInt -- lbearing (origin to left edge of raster) + , CInt -- rbearing (origin to right edge of raster) + , CInt -- width (advance to next char's origin) + , CInt -- ascent (baseline to top edge of raster) + , CInt -- descent (baseline to bottom edge of raster) + -- attributes omitted + ) peekCharStruct :: Ptr CharStruct -> IO CharStruct peekCharStruct p = do - lbearing <- #{peek XCharStruct,lbearing} p - rbearing <- #{peek XCharStruct,rbearing} p - width <- #{peek XCharStruct,width} p - ascent <- #{peek XCharStruct,ascent} p - descent <- #{peek XCharStruct,descent} p - return (fromIntegral (lbearing::CShort), - fromIntegral (rbearing::CShort), - fromIntegral (width::CShort), - fromIntegral (ascent::CShort), - fromIntegral (descent::CShort)) + lbearing <- #{peek XCharStruct,lbearing} p + rbearing <- #{peek XCharStruct,rbearing} p + width <- #{peek XCharStruct,width} p + ascent <- #{peek XCharStruct,ascent} p + descent <- #{peek XCharStruct,descent} p + return (fromIntegral (lbearing::CShort), + fromIntegral (rbearing::CShort), + fromIntegral (width::CShort), + fromIntegral (ascent::CShort), + fromIntegral (descent::CShort)) -- No need to put this in the IO monad - this info is essentially constant -- | interface to the X11 library function @XTextExtents()@. textExtents :: FontStruct -> String -> (FontDirection, Int32, Int32, CharStruct) textExtents font_struct string = unsafePerformIO $ - withCStringLen string $ \ (c_string, nchars) -> - alloca $ \ direction_return -> - alloca $ \ font_ascent_return -> - alloca $ \ font_descent_return -> - allocaBytes #{size XCharStruct} $ \ overall_return -> do - xTextExtents font_struct c_string (fromIntegral nchars) direction_return - font_ascent_return font_descent_return overall_return - direction <- peek direction_return - ascent <- peek font_ascent_return - descent <- peek font_descent_return - cs <- peekCharStruct overall_return - return (direction, ascent, descent, cs) + withCStringLen string $ \ (c_string, nchars) -> + alloca $ \ direction_return -> + alloca $ \ font_ascent_return -> + alloca $ \ font_descent_return -> + allocaBytes #{size XCharStruct} $ \ overall_return -> do + _ <- xTextExtents font_struct c_string (fromIntegral nchars) direction_return + font_ascent_return font_descent_return overall_return + direction <- peek direction_return + ascent <- peek font_ascent_return + descent <- peek font_descent_return + cs <- peekCharStruct overall_return + return (direction, ascent, descent, cs) foreign import ccall unsafe "HsXlib.h XTextExtents" - xTextExtents :: FontStruct -> CString -> CInt -> - Ptr FontDirection -> Ptr Int32 -> Ptr Int32 -> - Ptr CharStruct -> IO CInt + xTextExtents :: FontStruct -> CString -> CInt -> + Ptr FontDirection -> Ptr Int32 -> Ptr Int32 -> + Ptr CharStruct -> IO CInt -- No need to put ths in the IO monad - this info is essentially constant -- | interface to the X11 library function @XTextWidth()@. textWidth :: FontStruct -> String -> Int32 textWidth font_struct string = unsafePerformIO $ - withCStringLen string $ \ (c_string, len) -> - xTextWidth font_struct c_string (fromIntegral len) + withCStringLen string $ \ (c_string, len) -> + xTextWidth font_struct c_string (fromIntegral len) foreign import ccall unsafe "HsXlib.h XTextWidth" - xTextWidth :: FontStruct -> CString -> CInt -> IO Int32 + xTextWidth :: FontStruct -> CString -> CInt -> IO Int32 -- XTextExtents16 omitted -- XTextWidth16 omitted diff --git a/Graphics/X11/Xlib/Image.hs b/Graphics/X11/Xlib/Image.hs --- a/Graphics/X11/Xlib/Image.hs +++ b/Graphics/X11/Xlib/Image.hs @@ -17,15 +17,19 @@ createImage, putImage, destroyImage, + getImage, + xGetPixel, + getPixel ) where import Graphics.X11.Types import Graphics.X11.Xlib.Types -import Foreign --- import Foreign.C +import Foreign (Ptr, throwIfNull) import Foreign.C.Types +import System.IO.Unsafe (unsafePerformIO) + ---------------------------------------------------------------- -- Image ---------------------------------------------------------------- @@ -36,7 +40,7 @@ image <- throwIfNull "createImage" (xCreateImage display vis depth format offset dat width height bitmap_pad bytes_per_line) return (Image image) foreign import ccall unsafe "HsXlib.h XCreateImage" - xCreateImage :: Display -> Visual -> CInt -> ImageFormat -> CInt -> + xCreateImage :: Display -> Visual -> CInt -> ImageFormat -> CInt -> Ptr CChar -> Dimension -> Dimension -> CInt -> CInt -> IO (Ptr Image) -- | interface to the X11 library function @XPutImage()@. @@ -48,13 +52,25 @@ foreign import ccall unsafe "HsXlib.h XDestroyImage" destroyImage :: Image -> IO () +-- | interface to the X11 library function @XGetImage()@. +getImage :: Display -> Drawable -> CInt -> CInt -> CUInt -> CUInt -> CULong -> ImageFormat -> IO Image +getImage display d x y width height plane_mask format = do + image <- throwIfNull "getImage" (xGetImage display d x y width height plane_mask format) + return (Image image) + +foreign import ccall unsafe "HsXlib.h XGetImage" + xGetImage :: Display -> Drawable -> CInt -> CInt -> CUInt -> CUInt -> CULong -> ImageFormat -> IO (Ptr Image) + +foreign import ccall unsafe "HsXlib.h XGetPixel" + xGetPixel :: Image -> CInt -> CInt -> IO CULong + +-- | interface to the X11 library function @XGetPixel()@. +getPixel :: Image -> CInt -> CInt -> CULong +getPixel i x y = unsafePerformIO (xGetPixel i x y) + {- don't need XInitImage since Haskell users probably won't be setting members of the XImage structure themselves -} -- XInitImage omitted -{- these two functions are for fetching image data from a drawable -back into an image struct. i'm not exactly sure when they would be -used -} --- XGetImage omitted -- XGetSubImage omitted diff --git a/Graphics/X11/Xlib/Internal.hsc b/Graphics/X11/Xlib/Internal.hsc new file mode 100644 --- /dev/null +++ b/Graphics/X11/Xlib/Internal.hsc @@ -0,0 +1,20 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.X11.Xlib.Internal +-- Copyright : (c) Daniel Wagner, 2013 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Functions used often elsewhere in the X11 bindings. +-- +----------------------------------------------------------------------------- + +module Graphics.X11.Xlib.Internal (xFree) where + +import Foreign +import Foreign.C.Types + +foreign import ccall unsafe "XFree" xFree :: Ptr a -> IO CInt diff --git a/Graphics/X11/Xlib/Misc.hsc b/Graphics/X11/Xlib/Misc.hsc --- a/Graphics/X11/Xlib/Misc.hsc +++ b/Graphics/X11/Xlib/Misc.hsc @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.X11.Xlib.Misc @@ -73,6 +73,23 @@ getPointerControl, warpPointer, + -- * Visuals + visualIDFromVisual, + VisualInfoMask, + visualNoMask, + visualIDMask, + visualScreenMask, + visualDepthMask, + visualClassMask, + visualRedMaskMask, + visualGreenMaskMask, + visualBlueMaskMask, + visualColormapSizeMask, + visualBitsPerRGBMask, + visualAllMask, + getVisualInfo, + matchVisualInfo, + -- * Threads initThreads, lockDisplay, @@ -84,6 +101,7 @@ bitmapBitOrder, bitmapUnit, bitmapPad, + readBitmapFile, -- * Keycodes displayKeycodes, @@ -166,12 +184,15 @@ import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Event import Graphics.X11.Xlib.Font +import Graphics.X11.Xlib.Internal -import Foreign +import Foreign (Storable, Ptr, alloca, peek, throwIfNull, with, withArrayLen, allocaBytes, pokeByteOff, withArray, FunPtr, nullPtr, Word32, peekArray) import Foreign.C +import System.IO.Unsafe + #if __GLASGOW_HASKELL__ -import Data.Generics +import Data.Data #endif #include "HsXlib.h" @@ -247,11 +268,11 @@ -- | interface to the X11 library function @XGrabKey()@. foreign import ccall unsafe "HsXlib.h XGrabKey" - grabKey :: Display -> KeyCode -> ButtonMask -> Window -> Bool -> GrabMode -> GrabMode -> IO () + grabKey :: Display -> KeyCode -> KeyMask -> Window -> Bool -> GrabMode -> GrabMode -> IO () -- | interface to the X11 library function @XUngrabKey()@. foreign import ccall unsafe "HsXlib.h XUngrabKey" - ungrabKey :: Display -> KeyCode -> ButtonMask -> Window -> IO () + ungrabKey :: Display -> KeyCode -> KeyMask -> Window -> IO () -- | interface to the X11 library function @XGrabKeyboard()@. foreign import ccall unsafe "HsXlib.h XGrabKeyboard" @@ -271,9 +292,6 @@ -- XChangeActivePointerGrab omitted --- | interface to the X11 library function @XFree()@. -foreign import ccall unsafe "HsXlib.h XFree" xFree :: Ptr a -> IO () - -- XFreeStringList omitted -- | interface to the X11 library function @XQueryBestTile()@. @@ -461,7 +479,7 @@ -- textual representation of the error. setDefaultErrorHandler :: IO () setDefaultErrorHandler = do - xSetErrorHandler defaultErrorHandler + _ <- xSetErrorHandler defaultErrorHandler return () -- %fun XSetIOErrorHandler :: IOErrorHandler -> IO IOErrorHandler @@ -673,13 +691,58 @@ ---------------------------------------------------------------- -- | see @XVisualIDFromVisual()@ ---foreign import ccall unsafe "HsXlib.h XVisualIDFromVisual" --- visualIDFromVisual :: Visual -> IO VisualID +foreign import ccall unsafe "HsXlib.h XVisualIDFromVisual" + visualIDFromVisual :: Visual -> IO VisualID --- XGetVisualInfo omitted --- XMatchVisualInfo omitted +type VisualInfoMask = CLong +#{enum VisualInfoMask, + , visualNoMask = VisualNoMask + , visualIDMask = VisualIDMask + , visualScreenMask = VisualScreenMask + , visualDepthMask = VisualDepthMask + , visualClassMask = VisualClassMask + , visualRedMaskMask = VisualRedMaskMask + , visualGreenMaskMask = VisualGreenMaskMask + , visualBlueMaskMask = VisualBlueMaskMask + , visualColormapSizeMask = VisualColormapSizeMask + , visualBitsPerRGBMask = VisualBitsPerRGBMask + , visualAllMask = VisualAllMask + } +-- | interface to the X11 library function @XGetVisualInfo()@ +getVisualInfo :: Display -> VisualInfoMask -> VisualInfo -> IO [VisualInfo] +getVisualInfo dpy mask template = + alloca $ \nItemsPtr -> + with template $ \templatePtr -> do + itemsPtr <- xGetVisualInfo dpy mask templatePtr nItemsPtr + if itemsPtr == nullPtr + then return [] + else do + nItems <- peek nItemsPtr + items <- peekArray (fromIntegral nItems) itemsPtr + _ <- xFree itemsPtr + return items +foreign import ccall unsafe "XGetVisualInfo" + xGetVisualInfo :: Display -> VisualInfoMask -> Ptr VisualInfo -> + Ptr CInt -> IO (Ptr VisualInfo) + +-- | interface to the X11 library function @XMatchVisualInfo()@ +matchVisualInfo + :: Display -> ScreenNumber -> CInt -> CInt -> IO (Maybe VisualInfo) +matchVisualInfo dpy screen depth class_ = + alloca $ \infoPtr -> do + status <- xMatchVisualInfo dpy screen depth class_ infoPtr + if status == 0 + then return Nothing + else do + info <- peek infoPtr + return $ Just info + +foreign import ccall unsafe "XMatchVisualInfo" + xMatchVisualInfo :: Display -> ScreenNumber -> CInt -> CInt -> + Ptr VisualInfo -> IO Status + ---------------------------------------------------------------- -- Threads ---------------------------------------------------------------- @@ -690,7 +753,7 @@ foreign import ccall unsafe "HsXlib.h XLockDisplay" lockDisplay :: Display -> IO () -foreign import ccall unsafe "HsXlib.h XLockDisplay" +foreign import ccall unsafe "HsXlib.h XUnlockDisplay" unlockDisplay :: Display -> IO () ---------------------------------------------------------------- @@ -742,7 +805,7 @@ -- IN Maybe Int y_hot = -1 -- POST: RETVAL == BitmapSuccess --- omitted +-- added: unstable -- IMPURE void XReadBitmapFile(display, d, filename, bitmap, width, height, x_hot, y_hot) RAISES Either -- RETURNTYPE BitmapFileStatus -- GLOBAL ERROR BitmapFileStatus RETVAL @@ -756,6 +819,37 @@ -- OUT Int y_hot RAISES Maybe IF x_hot == -1 -- POST: RETVAL == BitmapSuccess +-- | interface to the X11 library function @XReadBitmapFile@. +readBitmapFile :: Display -> Drawable -> String + -> IO (Either String (Dimension, Dimension, Pixmap, Maybe CInt, Maybe CInt)) +readBitmapFile display d filename = + withCString filename $ \ c_filename -> + alloca $ \ width_return -> + alloca $ \ height_return -> + alloca $ \ bitmap_return -> + alloca $ \ x_hot_return -> + alloca $ \ y_hot_return -> do + rv <- xReadBitmapFile display d c_filename width_return height_return + bitmap_return x_hot_return y_hot_return + width <- peek width_return + height <- peek height_return + bitmap <- peek bitmap_return + x_hot <- peek x_hot_return + y_hot <- peek y_hot_return + let m_x_hot | x_hot == -1 = Nothing + | otherwise = Just x_hot + m_y_hot | y_hot == -1 = Nothing + | otherwise = Just y_hot + case rv of + 0 -> return $ Right (width, height, bitmap, m_x_hot, m_y_hot) + 1 -> return $ Left "readBitmapFile: BitmapOpenFailed" + 2 -> return $ Left "readBitmapFile: BitmapFileInvalid" + 3 -> return $ Left "readBitmapFile: BitmapNoMemory" + _ -> return $ Left "readBitmapFile: BitmapUnknownError" +foreign import ccall unsafe "X11/Xlib.h XReadBitmapFile" + xReadBitmapFile :: Display -> Drawable -> CString -> Ptr Dimension -> Ptr Dimension + -> Ptr Pixmap -> Ptr CInt -> Ptr CInt -> IO CInt + -- XCreateBitmapFromData omitted (awkward looking type) -- XReadBitmapFileData omitted (awkward looking type) @@ -1147,7 +1241,7 @@ xFetchBuffer display nbytes_return buffer nbytes <- peek nbytes_return bytes <- peekCStringLen (c_bytes, (fromIntegral nbytes)) - xFree c_bytes + _ <- xFree c_bytes return bytes foreign import ccall unsafe "HsXlib.h XFetchBuffer" xFetchBuffer :: Display -> Ptr CInt -> CInt -> IO CString @@ -1160,7 +1254,7 @@ xFetchBytes display nbytes_return nbytes <- peek nbytes_return bytes <- peekCStringLen (c_bytes, (fromIntegral nbytes)) - xFree c_bytes + _ <- xFree c_bytes return bytes foreign import ccall unsafe "HsXlib.h XFetchBytes" xFetchBytes :: Display -> Ptr CInt -> IO CString diff --git a/Graphics/X11/Xlib/Region.hs b/Graphics/X11/Xlib/Region.hs --- a/Graphics/X11/Xlib/Region.hs +++ b/Graphics/X11/Xlib/Region.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.X11.Xlib.Region @@ -51,7 +51,7 @@ import Foreign.Marshal.Utils #if __GLASGOW_HASKELL__ -import Data.Generics +import Data.Data #endif ---------------------------------------------------------------- diff --git a/Graphics/X11/Xlib/Types.hsc b/Graphics/X11/Xlib/Types.hsc --- a/Graphics/X11/Xlib/Types.hsc +++ b/Graphics/X11/Xlib/Types.hsc @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} +{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.X11.Xlib.Types @@ -16,10 +16,13 @@ -- #hide module Graphics.X11.Xlib.Types( Display(..), Screen(..), Visual(..), GC(..), GCValues, SetWindowAttributes, + VisualInfo(..), Image(..), Point(..), Rectangle(..), Arc(..), Segment(..), Color(..), Pixel, Position, Dimension, Angle, ScreenNumber, Buffer ) where +import Graphics.X11.Types + -- import Control.Monad( zipWithM_ ) import Data.Int import Data.Word @@ -29,9 +32,11 @@ import Foreign.Storable( Storable(..) ) #if __GLASGOW_HASKELL__ -import Data.Generics +import Data.Data #endif +import Data.Default.Class + #include "HsXlib.h" ---------------------------------------------------------------- @@ -85,6 +90,81 @@ #else deriving (Eq, Ord, Show) #endif + +-- | counterpart of an X11 @XVisualInfo@ structure +data VisualInfo = VisualInfo { + visualInfo_visual :: Visual, + visualInfo_visualID :: VisualID, + visualInfo_screen :: ScreenNumber, + visualInfo_depth :: CInt, + visualInfo_class :: CInt, + visualInfo_redMask :: CULong, + visualInfo_greenMask :: CULong, + visualInfo_blueMask :: CULong, + visualInfo_colormapSize :: CInt, + visualInfo_bitsPerRGB :: CInt + } +#if __GLASGOW_HASKELL__ + deriving (Eq, Show, Typeable) +#else + deriving (Eq, Show) +#endif + +instance Default VisualInfo where + def = VisualInfo { + visualInfo_visual = Visual nullPtr, + visualInfo_visualID = 0, + visualInfo_screen = 0, + visualInfo_depth = 0, + visualInfo_class = 0, + visualInfo_redMask = 0, + visualInfo_greenMask = 0, + visualInfo_blueMask = 0, + visualInfo_colormapSize = 0, + visualInfo_bitsPerRGB = 0 + } + +instance Storable VisualInfo where + sizeOf _ = #size XVisualInfo + alignment _ = alignment (undefined::CInt) + peek p = do + visual <- Visual `fmap` #{peek XVisualInfo, visual} p + visualID <- #{peek XVisualInfo, visualid} p + screen <- #{peek XVisualInfo, screen} p + depth <- #{peek XVisualInfo, depth} p + class_ <- #{peek XVisualInfo, class} p + redMask <- #{peek XVisualInfo, red_mask} p + greenMask <- #{peek XVisualInfo, green_mask} p + blueMask <- #{peek XVisualInfo, blue_mask} p + colormapSize <- #{peek XVisualInfo, colormap_size} p + bitsPerRGB <- #{peek XVisualInfo, bits_per_rgb} p + return $ VisualInfo { + visualInfo_visual = visual, + visualInfo_visualID = visualID, + visualInfo_screen = screen, + visualInfo_depth = depth, + visualInfo_class = class_, + visualInfo_redMask = redMask, + visualInfo_greenMask = greenMask, + visualInfo_blueMask = blueMask, + visualInfo_colormapSize = colormapSize, + visualInfo_bitsPerRGB = bitsPerRGB + } + poke p info = do + #{poke XVisualInfo, visual} p visualPtr + #{poke XVisualInfo, visualid} p $ visualInfo_visualID info + #{poke XVisualInfo, screen} p $ visualInfo_screen info + #{poke XVisualInfo, depth} p $ visualInfo_depth info + #{poke XVisualInfo, class} p $ visualInfo_class info + #{poke XVisualInfo, red_mask} p $ visualInfo_redMask info + #{poke XVisualInfo, green_mask} p $ visualInfo_greenMask info + #{poke XVisualInfo, blue_mask} p $ visualInfo_blueMask info + #{poke XVisualInfo, colormap_size} p $ + visualInfo_colormapSize info + #{poke XVisualInfo, bits_per_rgb} p $ + visualInfo_bitsPerRGB info + where + ~(Visual visualPtr) = visualInfo_visual info -- | pointer to an X11 @XImage@ structure newtype Image = Image (Ptr Image) diff --git a/Graphics/X11/Xlib/Window.hs b/Graphics/X11/Xlib/Window.hs --- a/Graphics/X11/Xlib/Window.hs +++ b/Graphics/X11/Xlib/Window.hs @@ -53,7 +53,6 @@ import Foreign import Foreign.C -import Foreign.C.Types ---------------------------------------------------------------- -- Windows diff --git a/Graphics/X11/Xrandr.hsc b/Graphics/X11/Xrandr.hsc new file mode 100644 --- /dev/null +++ b/Graphics/X11/Xrandr.hsc @@ -0,0 +1,778 @@ +{-# LANGUAGE DeriveDataTypeable #-} +-------------------------------------------------------------------- +-- | +-- Module : Graphics.X11.Xrandr +-- Copyright : (c) Haskell.org, 2012 +-- (c) Jochen Keil, 2012 +-- License : BSD3 +-- +-- Maintainer: Ben Boeckel +-- , Jochen Keil +-- +-- Stability : provisional +-- Portability: portable +-- +-------------------------------------------------------------------- +-- +-- Interface to Xrandr API +-- + +module Graphics.X11.Xrandr ( + XRRScreenSize(..), + XRRModeInfo(..), + XRRScreenResources(..), + XRROutputInfo(..), + XRRCrtcInfo(..), + XRRPropertyInfo(..), + XRRMonitorInfo(..), + compiledWithXrandr, + Rotation, + Reflection, + SizeID, + XRRScreenConfiguration, + xrrQueryExtension, + xrrQueryVersion, + xrrGetScreenInfo, + xrrFreeScreenConfigInfo, + xrrSetScreenConfig, + xrrSetScreenConfigAndRate, + xrrConfigRotations, + xrrConfigTimes, + xrrConfigSizes, + xrrConfigRates, + xrrConfigCurrentConfiguration, + xrrConfigCurrentRate, + xrrRootToScreen, + xrrSelectInput, + xrrUpdateConfiguration, + xrrRotations, + xrrSizes, + xrrRates, + xrrTimes, + xrrGetScreenResources, + xrrGetOutputInfo, + xrrGetCrtcInfo, + xrrGetScreenResourcesCurrent, + xrrSetOutputPrimary, + xrrGetOutputPrimary, + xrrListOutputProperties, + xrrQueryOutputProperty, + xrrConfigureOutputProperty, + xrrChangeOutputProperty, + xrrGetOutputProperty, + xrrDeleteOutputProperty, + xrrGetMonitors, + ) where + +import Foreign +import Foreign.C.Types +import Foreign.C.String +import Control.Monad + +import Graphics.X11.Xlib.Event +import Graphics.X11.Xlib.Internal +import Graphics.X11.Xlib.Types +import Graphics.X11.Types + +#if __GLASGOW_HASKELL__ +import Data.Data +#endif + +-- | Representation of the XRRScreenSize struct +data XRRScreenSize = XRRScreenSize + { xrr_ss_width :: !CInt, + xrr_ss_height :: !CInt, + xrr_ss_mwidth :: !CInt, + xrr_ss_mheight :: !CInt } + deriving (Show) + +-- | Representation of the XRRModeInfo struct +data XRRModeInfo = XRRModeInfo + { xrr_mi_id :: !RRMode + , xrr_mi_width :: !CUInt + , xrr_mi_height :: !CUInt + , xrr_mi_dotClock :: !CUInt + , xrr_mi_hSyncStart :: !CUInt + , xrr_mi_hSyncEnd :: !CUInt + , xrr_mi_hTotal :: !CUInt + , xrr_mi_hSkew :: !CUInt + , xrr_mi_vSyncStart :: !CUInt + , xrr_mi_vSyncEnd :: !CUInt + , xrr_mi_vTotal :: !CUInt + , xrr_mi_name :: !String + , xrr_mi_modeFlags :: !XRRModeFlags + } deriving (Eq, Show) + +-- | Representation of the XRRScreenResources struct +data XRRScreenResources = XRRScreenResources + { xrr_sr_timestamp :: !Time + , xrr_sr_configTimestamp :: !Time + , xrr_sr_crtcs :: [RRCrtc] + , xrr_sr_outputs :: [RROutput] + , xrr_sr_modes :: [XRRModeInfo] + } deriving (Eq, Show) + +-- | Representation of the XRROutputInfo struct +data XRROutputInfo = XRROutputInfo + { xrr_oi_timestamp :: !Time + , xrr_oi_crtc :: !RRCrtc + , xrr_oi_name :: !String + , xrr_oi_mm_width :: !CULong + , xrr_oi_mm_height :: !CULong + , xrr_oi_connection :: !Connection + , xrr_oi_subpixel_order :: !SubpixelOrder + , xrr_oi_crtcs :: [RRCrtc] + , xrr_oi_clones :: [RROutput] + , xrr_oi_npreferred :: !CInt + , xrr_oi_modes :: [RRMode] + } deriving (Eq, Show) + +-- | Representation of the XRRCrtcInfo struct +data XRRCrtcInfo = XRRCrtcInfo + { xrr_ci_timestamp :: !Time + , xrr_ci_x :: !CInt + , xrr_ci_y :: !CInt + , xrr_ci_width :: !CUInt + , xrr_ci_height :: !CUInt + , xrr_ci_mode :: !RRMode + , xrr_ci_rotation :: !Rotation + , xrr_ci_outputs :: [RROutput] + , xrr_ci_rotations :: !Rotation + , xrr_ci_possible :: [RROutput] + } deriving (Eq, Show) + +-- | Representation of the XRRPropertyInfo struct +data XRRPropertyInfo = XRRPropertyInfo + { xrr_pi_pending :: !Bool + , xrr_pi_range :: !Bool + , xrr_pi_immutable :: !Bool + , xrr_pi_values :: [CLong] + } deriving (Eq, Show) + +-- | Representation of the XRRMonitorInfo struct +data XRRMonitorInfo = XRRMonitorInfo + { xrr_moninf_name :: !Atom + , xrr_moninf_primary :: !Bool + , xrr_moninf_automatic :: !Bool + , xrr_moninf_x :: !CInt + , xrr_moninf_y :: !CInt + , xrr_moninf_width :: !CInt + , xrr_moninf_height :: !CInt + , xrr_moninf_mwidth :: !CInt + , xrr_moninf_mheight :: !CInt + , xrr_moninf_outputs :: [RROutput] + } deriving (Eq, Show) + +-- We have Xrandr, so the library will actually work +compiledWithXrandr :: Bool +compiledWithXrandr = True + +#include "HsXlib.h" + +newtype XRRScreenConfiguration = XRRScreenConfiguration (Ptr XRRScreenConfiguration) +#if __GLASGOW_HASKELL__ + deriving (Eq, Ord, Show, Typeable, Data) +#else + deriving (Eq, Ord, Show) +#endif + +instance Storable XRRScreenSize where + sizeOf _ = #{size XRRScreenSize} + -- FIXME: Is this right? + alignment _ = alignment (undefined :: CInt) + + poke p xrr_ss = do + #{poke XRRScreenSize, width } p $ xrr_ss_width xrr_ss + #{poke XRRScreenSize, height } p $ xrr_ss_height xrr_ss + #{poke XRRScreenSize, mwidth } p $ xrr_ss_mwidth xrr_ss + #{poke XRRScreenSize, mheight } p $ xrr_ss_mheight xrr_ss + + peek p = return XRRScreenSize + `ap` (#{peek XRRScreenSize, width} p) + `ap` (#{peek XRRScreenSize, height} p) + `ap` (#{peek XRRScreenSize, mwidth} p) + `ap` (#{peek XRRScreenSize, mheight} p) + +instance Storable XRRModeInfo where + sizeOf _ = #{size XRRModeInfo} + -- FIXME: Is this right? + alignment _ = alignment (undefined :: CInt) + + poke p xrr_mi = do + #{poke XRRModeInfo, id } p $ xrr_mi_id xrr_mi + #{poke XRRModeInfo, width } p $ xrr_mi_width xrr_mi + #{poke XRRModeInfo, height } p $ xrr_mi_height xrr_mi + #{poke XRRModeInfo, dotClock } p $ xrr_mi_dotClock xrr_mi + #{poke XRRModeInfo, hSyncStart } p $ xrr_mi_hSyncStart xrr_mi + #{poke XRRModeInfo, hSyncEnd } p $ xrr_mi_hSyncEnd xrr_mi + #{poke XRRModeInfo, hTotal } p $ xrr_mi_hTotal xrr_mi + #{poke XRRModeInfo, hSkew } p $ xrr_mi_hSkew xrr_mi + #{poke XRRModeInfo, vSyncStart } p $ xrr_mi_vSyncStart xrr_mi + #{poke XRRModeInfo, vSyncEnd } p $ xrr_mi_vSyncEnd xrr_mi + #{poke XRRModeInfo, vTotal } p $ xrr_mi_vTotal xrr_mi + #{poke XRRModeInfo, modeFlags } p $ xrr_mi_modeFlags xrr_mi + -- see comment in Storable XRRScreenResources about dynamic resource allocation + #{poke XRRModeInfo, nameLength } p ( 0 :: CInt ) + #{poke XRRModeInfo, name } p ( nullPtr :: Ptr CChar ) + + peek p = return XRRModeInfo + `ap` ( #{peek XRRModeInfo, id } p ) + `ap` ( #{peek XRRModeInfo, width } p ) + `ap` ( #{peek XRRModeInfo, height } p ) + `ap` ( #{peek XRRModeInfo, dotClock } p ) + `ap` ( #{peek XRRModeInfo, hSyncStart } p ) + `ap` ( #{peek XRRModeInfo, hSyncEnd } p ) + `ap` ( #{peek XRRModeInfo, hTotal } p ) + `ap` ( #{peek XRRModeInfo, hSkew } p ) + `ap` ( #{peek XRRModeInfo, vSyncStart } p ) + `ap` ( #{peek XRRModeInfo, vSyncEnd } p ) + `ap` ( #{peek XRRModeInfo, vTotal } p ) + `ap` peekCStringLenIO (#{peek XRRModeInfo, nameLength } p) + (#{peek XRRModeInfo, name } p) + `ap` ( #{peek XRRModeInfo, modeFlags } p ) + +instance Storable XRRMonitorInfo where + sizeOf _ = #{size XRRMonitorInfo} + -- FIXME: Is this right? + alignment _ = alignment (undefined :: CInt) + + poke p xrr_moninf = do + #{poke XRRMonitorInfo, name } p $ xrr_moninf_name xrr_moninf + #{poke XRRMonitorInfo, primary } p $ xrr_moninf_primary xrr_moninf + #{poke XRRMonitorInfo, automatic } p $ xrr_moninf_automatic xrr_moninf + #{poke XRRMonitorInfo, x } p $ xrr_moninf_x xrr_moninf + #{poke XRRMonitorInfo, y } p $ xrr_moninf_y xrr_moninf + #{poke XRRMonitorInfo, width } p $ xrr_moninf_width xrr_moninf + #{poke XRRMonitorInfo, height } p $ xrr_moninf_height xrr_moninf + #{poke XRRMonitorInfo, mwidth } p $ xrr_moninf_mwidth xrr_moninf + #{poke XRRMonitorInfo, mheight } p $ xrr_moninf_mheight xrr_moninf + -- see comment in Storable XRRScreenResources about dynamic resource allocation + #{poke XRRMonitorInfo, noutput } p ( 0 :: CInt ) + #{poke XRRMonitorInfo, outputs } p ( nullPtr :: Ptr RROutput ) + + peek p = return XRRMonitorInfo + `ap` ( #{peek XRRMonitorInfo, name } p ) + `ap` ( #{peek XRRMonitorInfo, primary } p ) + `ap` ( #{peek XRRMonitorInfo, automatic } p ) + `ap` ( #{peek XRRMonitorInfo, x } p ) + `ap` ( #{peek XRRMonitorInfo, y } p ) + `ap` ( #{peek XRRMonitorInfo, width } p ) + `ap` ( #{peek XRRMonitorInfo, height } p ) + `ap` ( #{peek XRRMonitorInfo, mwidth } p ) + `ap` ( #{peek XRRMonitorInfo, mheight } p ) + `ap` peekCArrayIO (#{peek XRRMonitorInfo, noutput } p) + (#{peek XRRMonitorInfo, outputs } p) + + +instance Storable XRRScreenResources where + sizeOf _ = #{size XRRScreenResources} + -- FIXME: Is this right? + alignment _ = alignment (undefined :: CInt) + + poke p xrr_sr = do + #{poke XRRScreenResources, timestamp } p $ xrr_sr_timestamp xrr_sr + #{poke XRRScreenResources, configTimestamp } p $ xrr_sr_configTimestamp xrr_sr + -- there is no simple way to handle ptrs to arrays or struct through ffi + -- Using plain malloc will result in a memory leak, unless the poking + -- function will free the memory manually + -- Unfortunately a ForeignPtr with a Finalizer is not going to work + -- either, because the Finalizer will be run after poke returns, making + -- the allocated memory unusable. + -- The safest option is therefore probably to have the calling function + -- handle this issue for itself + -- e.g. + -- #{poke XRRScreenResources, ncrtc} p ( fromIntegral $ length $ xrr_sr_crtcs xrr_sr :: CInt ) + -- crtcp <- mallocArray $ length $ xrr_sr_crtcs xrr_sr + -- pokeArray crtcp $ xrr_sr_crtcs xrr_sr + -- #{poke XRRScreenResources, crtcs} p crtcp + #{poke XRRScreenResources, ncrtc } p ( 0 :: CInt ) + #{poke XRRScreenResources, noutput } p ( 0 :: CInt ) + #{poke XRRScreenResources, nmode } p ( 0 :: CInt ) + #{poke XRRScreenResources, crtcs } p ( nullPtr :: Ptr RRCrtc ) + #{poke XRRScreenResources, outputs } p ( nullPtr :: Ptr RROutput ) + #{poke XRRScreenResources, modes } p ( nullPtr :: Ptr XRRModeInfo ) + + peek p = return XRRScreenResources + `ap` ( #{peek XRRScreenResources, timestamp } p ) + `ap` ( #{peek XRRScreenResources, configTimestamp } p ) + `ap` peekCArrayIO (#{peek XRRScreenResources, ncrtc } p) + (#{peek XRRScreenResources, crtcs } p) + `ap` peekCArrayIO (#{peek XRRScreenResources, noutput } p) + (#{peek XRRScreenResources, outputs } p) + `ap` peekCArrayIO (#{peek XRRScreenResources, nmode } p) + (#{peek XRRScreenResources, modes } p) + + +instance Storable XRROutputInfo where + sizeOf _ = #{size XRROutputInfo} + -- FIXME: Is this right? + alignment _ = alignment (undefined :: CInt) + + poke p xrr_oi = do + #{poke XRROutputInfo, timestamp } p $ xrr_oi_timestamp xrr_oi + #{poke XRROutputInfo, crtc } p $ xrr_oi_crtc xrr_oi + #{poke XRROutputInfo, mm_width } p $ xrr_oi_mm_width xrr_oi + #{poke XRROutputInfo, mm_height } p $ xrr_oi_mm_height xrr_oi + #{poke XRROutputInfo, connection } p $ xrr_oi_connection xrr_oi + #{poke XRROutputInfo, subpixel_order } p $ xrr_oi_subpixel_order xrr_oi + #{poke XRROutputInfo, npreferred } p $ xrr_oi_npreferred xrr_oi + -- see comment in Storable XRRScreenResources about dynamic resource allocation + #{poke XRROutputInfo, nameLen } p ( 0 :: CInt ) + #{poke XRROutputInfo, ncrtc } p ( 0 :: CInt ) + #{poke XRROutputInfo, nclone } p ( 0 :: CInt ) + #{poke XRROutputInfo, nmode } p ( 0 :: CInt ) + #{poke XRROutputInfo, name } p ( nullPtr :: Ptr CChar ) + #{poke XRROutputInfo, crtcs } p ( nullPtr :: Ptr RRCrtc ) + #{poke XRROutputInfo, clones } p ( nullPtr :: Ptr RROutput ) + #{poke XRROutputInfo, modes } p ( nullPtr :: Ptr RRMode ) + + peek p = return XRROutputInfo + `ap` ( #{peek XRROutputInfo, timestamp } p ) + `ap` ( #{peek XRROutputInfo, crtc } p ) + `ap` peekCStringLenIO (#{peek XRROutputInfo, nameLen } p) + (#{peek XRROutputInfo, name } p) + `ap` ( #{peek XRROutputInfo, mm_width } p ) + `ap` ( #{peek XRROutputInfo, mm_height } p ) + `ap` ( #{peek XRROutputInfo, connection } p ) + `ap` ( #{peek XRROutputInfo, subpixel_order } p ) + `ap` peekCArrayIO (#{peek XRROutputInfo, ncrtc } p) + (#{peek XRROutputInfo, crtcs } p) + `ap` peekCArrayIO (#{peek XRROutputInfo, nclone } p) + (#{peek XRROutputInfo, clones } p) + `ap` ( #{peek XRROutputInfo, npreferred } p ) + `ap` peekCArrayIO (#{peek XRROutputInfo, nmode } p) + (#{peek XRROutputInfo, modes } p) + + +instance Storable XRRCrtcInfo where + sizeOf _ = #{size XRRCrtcInfo} + -- FIXME: Is this right? + alignment _ = alignment (undefined :: CInt) + + poke p xrr_ci = do + #{poke XRRCrtcInfo, timestamp } p $ xrr_ci_timestamp xrr_ci + #{poke XRRCrtcInfo, x } p $ xrr_ci_x xrr_ci + #{poke XRRCrtcInfo, y } p $ xrr_ci_y xrr_ci + #{poke XRRCrtcInfo, width } p $ xrr_ci_width xrr_ci + #{poke XRRCrtcInfo, height } p $ xrr_ci_height xrr_ci + #{poke XRRCrtcInfo, mode } p $ xrr_ci_mode xrr_ci + #{poke XRRCrtcInfo, rotation } p $ xrr_ci_rotation xrr_ci + #{poke XRRCrtcInfo, rotations } p $ xrr_ci_rotations xrr_ci + -- see comment in Storable XRRScreenResources about dynamic resource allocation + #{poke XRRCrtcInfo, noutput } p ( 0 :: CInt ) + #{poke XRRCrtcInfo, npossible } p ( 0 :: CInt ) + #{poke XRRCrtcInfo, outputs } p ( nullPtr :: Ptr RROutput ) + #{poke XRRCrtcInfo, possible } p ( nullPtr :: Ptr RROutput ) + + peek p = return XRRCrtcInfo + `ap` ( #{peek XRRCrtcInfo, timestamp } p ) + `ap` ( #{peek XRRCrtcInfo, x } p ) + `ap` ( #{peek XRRCrtcInfo, y } p ) + `ap` ( #{peek XRRCrtcInfo, width } p ) + `ap` ( #{peek XRRCrtcInfo, height } p ) + `ap` ( #{peek XRRCrtcInfo, mode } p ) + `ap` ( #{peek XRRCrtcInfo, rotation } p ) + `ap` peekCArrayIO (#{peek XRRCrtcInfo, noutput } p) + (#{peek XRRCrtcInfo, outputs } p) + `ap` ( #{peek XRRCrtcInfo, rotations } p ) + `ap` peekCArrayIO (#{peek XRRCrtcInfo, npossible } p) + (#{peek XRRCrtcInfo, possible } p) + + +instance Storable XRRPropertyInfo where + sizeOf _ = #{size XRRPropertyInfo} + -- FIXME: Is this right? + alignment _ = alignment (undefined :: CInt) + + poke p xrr_pi = do + #{poke XRRPropertyInfo, pending } p $ xrr_pi_pending xrr_pi + #{poke XRRPropertyInfo, range } p $ xrr_pi_range xrr_pi + #{poke XRRPropertyInfo, immutable } p $ xrr_pi_immutable xrr_pi + -- see comment in Storable XRRScreenResources about dynamic resource allocation + #{poke XRRPropertyInfo, num_values } p ( 0 :: CInt ) + #{poke XRRPropertyInfo, values } p ( nullPtr :: Ptr CLong ) + + peek p = return XRRPropertyInfo + `ap` ( #{peek XRRPropertyInfo, pending } p ) + `ap` ( #{peek XRRPropertyInfo, range } p ) + `ap` ( #{peek XRRPropertyInfo, immutable } p ) + `ap` peekCArrayIO ( #{peek XRRPropertyInfo, num_values} p) + ( #{peek XRRPropertyInfo, values} p) + + +xrrQueryExtension :: Display -> IO (Maybe (CInt, CInt)) +xrrQueryExtension dpy = wrapPtr2 (cXRRQueryExtension dpy) go + where go False _ _ = Nothing + go True eventbase errorbase = Just (fromIntegral eventbase, fromIntegral errorbase) +foreign import ccall "XRRQueryExtension" + cXRRQueryExtension :: Display -> Ptr CInt -> Ptr CInt -> IO Bool + +xrrQueryVersion :: Display -> IO (Maybe (CInt, CInt)) +xrrQueryVersion dpy = wrapPtr2 (cXRRQueryVersion dpy) go + where go False _ _ = Nothing + go True major minor = Just (fromIntegral major, fromIntegral minor) +foreign import ccall "XRRQueryVersion" + cXRRQueryVersion :: Display -> Ptr CInt -> Ptr CInt -> IO Bool + +xrrGetScreenInfo :: Display -> Drawable -> IO (Maybe XRRScreenConfiguration) +xrrGetScreenInfo dpy draw = do + p <- cXRRGetScreenInfo dpy draw + if p == nullPtr + then return Nothing + else return (Just (XRRScreenConfiguration p)) +foreign import ccall "XRRGetScreenInfo" + cXRRGetScreenInfo :: Display -> Drawable -> IO (Ptr XRRScreenConfiguration) + +xrrFreeScreenConfigInfo :: XRRScreenConfiguration -> IO () +xrrFreeScreenConfigInfo = cXRRFreeScreenConfigInfo +foreign import ccall "XRRFreeScreenConfigInfo" + cXRRFreeScreenConfigInfo :: XRRScreenConfiguration -> IO () + +xrrSetScreenConfig :: Display -> XRRScreenConfiguration -> Drawable -> CInt -> Rotation -> Time -> IO Status +xrrSetScreenConfig = cXRRSetScreenConfig +foreign import ccall "XRRSetScreenConfig" + cXRRSetScreenConfig :: Display -> XRRScreenConfiguration -> Drawable -> CInt -> Rotation -> Time -> IO Status + +xrrSetScreenConfigAndRate :: Display -> XRRScreenConfiguration -> Drawable -> CInt -> Rotation -> CShort -> Time -> IO Status +xrrSetScreenConfigAndRate = cXRRSetScreenConfigAndRate +foreign import ccall "XRRSetScreenConfigAndRate" + cXRRSetScreenConfigAndRate :: Display -> XRRScreenConfiguration -> Drawable -> CInt -> Rotation -> CShort -> Time -> IO Status + +xrrConfigRotations :: XRRScreenConfiguration -> IO (Rotation, Rotation) +xrrConfigRotations config = + withPool $ \pool -> do rptr <- pooledMalloc pool + rotations <- cXRRConfigRotations config rptr + cur_rotation <- peek rptr + return (rotations, cur_rotation) +foreign import ccall "XRRConfigRotations" + cXRRConfigRotations :: XRRScreenConfiguration -> Ptr Rotation -> IO Rotation + +xrrConfigTimes :: XRRScreenConfiguration -> IO (Time, Time) +xrrConfigTimes config = + withPool $ \pool -> do tptr <- pooledMalloc pool + time <- cXRRConfigTimes config tptr + cur_time <- peek tptr + return (time, cur_time) +foreign import ccall "XRRConfigTimes" + cXRRConfigTimes :: XRRScreenConfiguration -> Ptr Time -> IO Time + +xrrConfigSizes :: XRRScreenConfiguration -> IO (Maybe [XRRScreenSize]) +xrrConfigSizes config = + withPool $ \pool -> do intp <- pooledMalloc pool + p <- cXRRConfigSizes config intp + if p == nullPtr + then return Nothing + else do nsizes <- peek intp + sizes <- if nsizes == 0 + then return Nothing + else peekArray (fromIntegral nsizes) p >>= return . Just + return sizes +foreign import ccall "XRRConfigSizes" + cXRRConfigSizes :: XRRScreenConfiguration -> Ptr CInt -> IO (Ptr XRRScreenSize) + +xrrConfigRates :: XRRScreenConfiguration -> CInt -> IO (Maybe [CShort]) +xrrConfigRates config size_index = + withPool $ \pool -> do intp <- pooledMalloc pool + p <- cXRRConfigRates config size_index intp + if p == nullPtr + then return Nothing + else do nrates <- peek intp + rates <- if nrates == 0 + then return Nothing + else peekArray (fromIntegral nrates) p >>= return . Just + return rates +foreign import ccall "XRRConfigRates" + cXRRConfigRates :: XRRScreenConfiguration -> CInt -> Ptr CInt -> IO (Ptr CShort) + +xrrConfigCurrentConfiguration :: XRRScreenConfiguration -> IO (Rotation, SizeID) +xrrConfigCurrentConfiguration config = + withPool $ \pool -> do rptr <- pooledMalloc pool + sizeid <- cXRRConfigCurrentConfiguration config rptr + rotation <- peek rptr + return (rotation, sizeid) +foreign import ccall "XRRConfigCurrentConfiguration" + cXRRConfigCurrentConfiguration :: XRRScreenConfiguration -> Ptr Rotation -> IO SizeID + +xrrConfigCurrentRate :: XRRScreenConfiguration -> IO CShort +xrrConfigCurrentRate = cXRRConfigCurrentRate +foreign import ccall "XRRConfigCurrentRate" + cXRRConfigCurrentRate :: XRRScreenConfiguration -> IO CShort + +xrrRootToScreen :: Display -> Window -> IO CInt +xrrRootToScreen = cXRRRootToScreen +foreign import ccall "XRRRootToScreen" + cXRRRootToScreen :: Display -> Window -> IO CInt + +xrrSelectInput :: Display -> Window -> EventMask -> IO () +xrrSelectInput dpy window mask = cXRRSelectInput dpy window (fromIntegral mask) +foreign import ccall "XRRSelectInput" + cXRRSelectInput :: Display -> Window -> CInt -> IO () + +xrrUpdateConfiguration :: XEventPtr -> IO CInt +xrrUpdateConfiguration = cXRRUpdateConfiguration +foreign import ccall "XRRUpdateConfiguration" + cXRRUpdateConfiguration :: XEventPtr -> IO CInt + +xrrRotations :: Display -> CInt -> IO (Rotation, Rotation) +xrrRotations dpy screen = + withPool $ \pool -> do rptr <- pooledMalloc pool + rotations <- cXRRRotations dpy screen rptr + cur_rotation <- peek rptr + return (rotations, cur_rotation) +foreign import ccall "XRRRotations" + cXRRRotations :: Display -> CInt -> Ptr Rotation -> IO Rotation + +xrrSizes :: Display -> CInt -> IO (Maybe [XRRScreenSize]) +xrrSizes dpy screen = + withPool $ \pool -> do intp <- pooledMalloc pool + p <- cXRRSizes dpy screen intp + if p == nullPtr + then return Nothing + else do nsizes <- peek intp + sizes <- if nsizes == 0 + then return Nothing + else peekArray (fromIntegral nsizes) p >>= return . Just + return sizes +foreign import ccall "XRRSizes" + cXRRSizes :: Display -> CInt -> Ptr CInt -> IO (Ptr XRRScreenSize) + +xrrRates :: Display -> CInt -> CInt -> IO (Maybe [CShort]) +xrrRates dpy screen size_index = + withPool $ \pool -> do intp <- pooledMalloc pool + p <- cXRRRates dpy screen size_index intp + if p == nullPtr + then return Nothing + else do nrates <- peek intp + rates <- if nrates == 0 + then return Nothing + else peekArray (fromIntegral nrates) p >>= return . Just + return rates +foreign import ccall "XRRRates" + cXRRRates :: Display -> CInt -> CInt -> Ptr CInt -> IO (Ptr CShort) + +xrrTimes :: Display -> CInt -> IO (Time, Time) +xrrTimes dpy screen = + withPool $ \pool -> do tptr <- pooledMalloc pool + time <- cXRRTimes dpy screen tptr + config_time <- peek tptr + return (time, config_time) +foreign import ccall "XRRTimes" + cXRRTimes :: Display -> CInt -> Ptr Time -> IO Time + +xrrGetScreenResources :: Display -> Window -> IO (Maybe XRRScreenResources) +xrrGetScreenResources dpy win = do + srp <- cXRRGetScreenResources dpy win + if srp == nullPtr + then return Nothing + else do + res <- peek srp + cXRRFreeScreenResources srp + return $ Just res + +foreign import ccall "XRRGetScreenResources" + cXRRGetScreenResources :: Display -> Window -> IO (Ptr XRRScreenResources) + +foreign import ccall "XRRFreeScreenResources" + cXRRFreeScreenResources :: Ptr XRRScreenResources -> IO () + +xrrGetOutputInfo :: Display -> XRRScreenResources -> RROutput -> IO (Maybe XRROutputInfo) +xrrGetOutputInfo dpy xrr_sr rro = withPool $ \pool -> do + -- XRRGetOutputInfo only uses the timestamp field from the + -- XRRScreenResources struct, so it's probably ok to pass the incomplete + -- structure here (see also the poke implementation for the Storable + -- instance of XRRScreenResources) + -- Alternative version below; This is extremely slow, though! + {- xrrGetOutputInfo :: Display -> Window -> RROutput -> IO (Maybe XRROutputInfo) + xrrGetOutputInfo dpy win rro = do + srp <- cXRRGetScreenResources dpy win + oip <- cXRRGetOutputInfo dpy srp rro + cXRRFreeScreenResources srp + -} + oip <- pooledMalloc pool >>= \srp -> do + poke srp xrr_sr + cXRRGetOutputInfo dpy srp rro -- no need to free srp, because pool mem + + if oip == nullPtr + then return Nothing + else do + oi <- peek oip + _ <- cXRRFreeOutputInfo oip + return $ Just oi + +foreign import ccall "XRRGetOutputInfo" + cXRRGetOutputInfo :: Display -> Ptr XRRScreenResources -> RROutput -> IO (Ptr XRROutputInfo) + +foreign import ccall "XRRFreeOutputInfo" + cXRRFreeOutputInfo :: Ptr XRROutputInfo -> IO () + +xrrGetCrtcInfo :: Display -> XRRScreenResources -> RRCrtc -> IO (Maybe XRRCrtcInfo) +xrrGetCrtcInfo dpy xrr_sr crtc = withPool $ \pool -> do + -- XRRGetCrtcInfo only uses the timestamp field from the + -- XRRScreenResources struct, so it's probably ok to pass the incomplete + -- structure here (see also the poke implementation for the Storable + -- instance of XRRScreenResources) + cip <- pooledMalloc pool >>= \srp -> do + poke srp xrr_sr + cXRRGetCrtcInfo dpy srp crtc -- no need to free srp, because pool mem + + if cip == nullPtr + then return Nothing + else do + ci <- peek cip + cXRRFreeCrtcInfo cip + return $ Just ci + +foreign import ccall "XRRGetCrtcInfo" + cXRRGetCrtcInfo :: Display -> Ptr XRRScreenResources -> RRCrtc -> IO (Ptr XRRCrtcInfo) + +foreign import ccall "XRRFreeCrtcInfo" + cXRRFreeCrtcInfo :: Ptr XRRCrtcInfo -> IO () + +foreign import ccall "XRRSetOutputPrimary" + xrrSetOutputPrimary :: Display -> Window -> RROutput -> IO () + +foreign import ccall "XRRGetOutputPrimary" + xrrGetOutputPrimary :: Display -> Window -> IO RROutput + +xrrGetScreenResourcesCurrent :: Display -> Window -> IO (Maybe XRRScreenResources) +xrrGetScreenResourcesCurrent dpy win = do + srcp <- cXRRGetScreenResourcesCurrent dpy win + if srcp == nullPtr + then return Nothing + else do + res <- peek srcp + cXRRFreeScreenResources srcp + return $ Just res + +foreign import ccall "XRRGetScreenResourcesCurrent" + cXRRGetScreenResourcesCurrent :: Display -> Window -> IO (Ptr XRRScreenResources) + +xrrListOutputProperties :: Display -> RROutput -> IO (Maybe [Atom]) +xrrListOutputProperties dpy rro = withPool $ \pool -> do + intp <- pooledMalloc pool + p <- cXRRListOutputProperties dpy rro intp + if p == nullPtr + then return Nothing + else do + nprop <- peek intp + res <- fmap Just $ peekCArray nprop p + _ <- xFree p + return res + +foreign import ccall "XRRListOutputProperties" + cXRRListOutputProperties :: Display -> RROutput -> Ptr CInt -> IO (Ptr Atom) + +xrrQueryOutputProperty :: Display -> RROutput -> Atom -> IO (Maybe XRRPropertyInfo) +xrrQueryOutputProperty dpy rro prop = do + p <- cXRRQueryOutputProperty dpy rro prop + if p == nullPtr + then return Nothing + else do + res <- peek p + _ <- xFree p + return $ Just res + +foreign import ccall "XRRQueryOutputProperty" + cXRRQueryOutputProperty :: Display -> RROutput -> Atom -> IO (Ptr XRRPropertyInfo) + +xrrConfigureOutputProperty :: Display -> RROutput -> Atom -> Bool -> Bool -> [CLong] -> IO () +xrrConfigureOutputProperty dpy rro prop pend range xs = withArrayLen xs $ + cXRRConfigureOutputProperty dpy rro prop pend range . fromIntegral + +foreign import ccall "XRRConfigureOutputProperty" + cXRRConfigureOutputProperty :: Display -> RROutput -> Atom -> Bool -> Bool -> CInt -> Ptr CLong -> IO () + +xrrChangeOutputProperty :: Display -> RROutput -> Atom -> Atom -> CInt -> CInt -> [Word32] -> IO () +xrrChangeOutputProperty dpy rro prop typ format mode xs = withPool $ \pool -> do + ptr <- case format of + 8 -> pooledNewArray pool (map fromIntegral xs :: [Word8]) + 16 -> castPtr `fmap` pooledNewArray pool (map fromIntegral xs :: [Word16]) + 32 -> castPtr `fmap` pooledNewArray pool xs + _ -> error "invalid format" + + cXRRChangeOutputProperty dpy rro prop typ format mode ptr (fromIntegral $ length xs) + +foreign import ccall "XRRChangeOutputProperty" + cXRRChangeOutputProperty :: Display -> RROutput -> Atom -> Atom -> CInt -> CInt -> Ptr Word8 -> CInt -> IO () + +-- | @xrrGetOutputProperty display output property offset length delete pending propertyType@ +-- | returns @Maybe (actualType, format, bytesAfter, data)@. +xrrGetOutputProperty :: + Display -> RROutput -> Atom -> CLong -> CLong -> Bool -> Bool -> Atom -> + IO (Maybe (Atom, Int, CULong, [Word32])) +xrrGetOutputProperty dpy rro prop offset len delete preferPending reqType = withPool $ \pool -> do + actualTypep <- pooledMalloc pool + actualFormatp <- pooledMalloc pool + nItemsp <- pooledMalloc pool + bytesAfterp <- pooledMalloc pool + datapp <- pooledMalloc pool + status <- cXRRGetOutputProperty dpy rro prop offset len + delete preferPending reqType + actualTypep actualFormatp nItemsp bytesAfterp datapp + + if status /= 0 + then return Nothing + else do + format <- fmap fromIntegral (peek actualFormatp) + nitems <- fmap fromIntegral (peek nItemsp) + ptr <- peek datapp + + dat <- case format of + 0 -> return [] + 8 -> fmap (map fromIntegral) $ peekArray nitems ptr + 16 -> fmap (map fromIntegral) $ peekArray nitems (castPtr ptr :: Ptr Word16) + 32 -> peekArray nitems (castPtr ptr :: Ptr Word32) + _ -> error $ "impossible happened: prop format is not in 0,8,16,32 (" ++ show format ++ ")" + + _ <- if format /= 0 + then xFree ptr + else return 0 + + typ <- peek actualTypep + bytesAfter <- peek bytesAfterp + return $ Just (typ, format, bytesAfter, dat) + +foreign import ccall "XRRGetOutputProperty" + cXRRGetOutputProperty :: Display -> RROutput -> Atom -> CLong -> CLong -> Bool -> Bool + -> Atom -> Ptr Atom -> Ptr CInt -> Ptr CULong -> Ptr CULong -> Ptr (Ptr Word8) -> IO CInt + +xrrDeleteOutputProperty :: Display -> RROutput -> Atom -> IO () +xrrDeleteOutputProperty = cXRRDeleteOutputProperty +foreign import ccall "XRRDeleteOutputProperty" + cXRRDeleteOutputProperty :: Display -> RROutput -> Atom -> IO () + +xrrGetMonitors :: Display -> Drawable -> Bool -> IO (Maybe [XRRMonitorInfo]) +xrrGetMonitors dpy draw get_active = withPool $ \pool -> do + intp <- pooledMalloc pool + p <- cXRRGetMonitors dpy draw get_active intp + if p == nullPtr + then return Nothing + else do + nmonitors <- peek intp + res <- fmap Just $ peekCArray nmonitors p + cXRRFreeMonitors p + return res + +foreign import ccall "XRRGetMonitors" + cXRRGetMonitors :: Display -> Drawable -> Bool -> Ptr CInt -> IO (Ptr XRRMonitorInfo) + +foreign import ccall "XRRFreeMonitors" + cXRRFreeMonitors :: Ptr XRRMonitorInfo -> IO () + +wrapPtr2 :: (Storable a, Storable b) => (Ptr a -> Ptr b -> IO c) -> (c -> a -> b -> d) -> IO d +wrapPtr2 cfun f = + withPool $ \pool -> do aptr <- pooledMalloc pool + bptr <- pooledMalloc pool + ret <- cfun aptr bptr + a <- peek aptr + b <- peek bptr + return (f ret a b) + +peekCArray :: Storable a => CInt -> Ptr a -> IO [a] +peekCArray n = peekArray (fromIntegral n) + +peekCArrayIO :: Storable a => IO CInt -> IO (Ptr a) -> IO [a] +peekCArrayIO n = join . liftM2 peekCArray n + +peekCStringLenIO :: IO CInt -> IO (Ptr CChar) -> IO String +peekCStringLenIO n p = liftM2 (,) p (fmap fromIntegral n) >>= peekCStringLen diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,33 @@ +# Haskell binding to the X11 graphics library [![Hackage](https://img.shields.io/hackage/v/X11.svg?style=flat)](https://hackage.haskell.org/package/X11) [![Build Status](https://img.shields.io/travis/xmonad/X11.svg?style=flat)](https://travis-ci.org/xmonad/X11) + +To build this package using Cabal directly from Git, you must run +`autoreconf` before the usual Cabal build steps (configure/build/install). +`autoreconf` is included in the GNU autoconf tools. There is no need to run +the `configure` script: the `cabal configure` step will do this for you. + +If you are building from a source tarball, you can just use the standard Cabal +installation stanza: + + cabal configure + cabal build + cabal install + +Xinerama support is enabled by default if Xinerama headers are detected. To +disable Xinerama support, add the `--without-xinerama` flag to +`configure-option`: + + cabal configure --configure-option="--without-xinerama" + +However, if you are building from Git, X11 uses `autoconf`, so you need +to have `autoconf` installed and run `autoconf`/`autoheader` before building: + + autoconf + autoheader + +or + + autoreconf + +You will need development versions of at least the X11, xrandr, and XScreenSaver +libraries installed for the build to succeed; having the development version of +the Xinerama library will enable some optional bindings. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,2 @@ -module Main (main) where - import Distribution.Simple - -main :: IO () -main = defaultMainWithHooks defaultUserHooks +main = defaultMainWithHooks autoconfUserHooks diff --git a/X11.buildinfo.in b/X11.buildinfo.in --- a/X11.buildinfo.in +++ b/X11.buildinfo.in @@ -4,4 +4,5 @@ buildable: @BUILD_PACKAGE_BOOL@ cc-options: @X_CFLAGS@ @CPPFLAGS@ ld-options: @X_LIBS@ @LDFLAGS@ -@EXTRA_LIBRARIES@ +extra-libraries: @EXTRA_LIBRARIES@ +extra-lib-dirs: @X_LIBRARIES@ diff --git a/X11.cabal b/X11.cabal --- a/X11.cabal +++ b/X11.cabal @@ -1,70 +1,88 @@ name: X11 -version: 1.5.0.1 +version: 1.10.3 +synopsis: A binding to the X11 graphics library +description: A Haskell binding to the X11 graphics library. The binding is a direct + translation of the C binding; for documentation of these calls, refer + to \"The Xlib Programming Manual\", available online at + . license: BSD3 license-file: LICENSE -copyright: Alastair Reid, 1999-2003, libraries@haskell.org 2003-2007, Don Stewart 2007-2009, Spencer Janssen 2007-2009. +copyright: Alastair Reid, 1999-2003, libraries@haskell.org 2003-2007, + Don Stewart 2007-2009, Spencer Janssen 2007-2009, Daniel Wagner 2009-2011. maintainer: Daniel Wagner -homepage: https://github.com/haskell-pkg-janitors/X11 +tested-with: GHC == 7.10.3 || == 8.0.2 || == 8.2.2 || == 8.4.4 || == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.2 category: Graphics -synopsis: A binding to the X11 graphics library -description: A Haskell binding to the X11 graphics library. - The binding is a direct translation of the C binding; for - documentation of these calls, refer to "The Xlib Programming - Manual", available online at . -extra-source-files: - configure.ac configure - config.mk.in X11.buildinfo.in include/HsX11Config.h.in - include/HsXlib.h include/XlibExtras.h include/X11_extras_config.h.in - include/HsAllKeysyms.h -extra-tmp-files: - config.log config.status autom4te.cache - config.mk X11.buildinfo include/HsX11Config.h - include/X11_extras_config.h -Cabal-Version: >= 1.2 +homepage: https://github.com/xmonad/X11 +bug-reports: https://github.com/xmonad/X11/issues build-type: Configure +extra-tmp-files: config.log + config.status + autom4te.cache + config.mk + X11.buildinfo + include/HsX11Config.h + include/X11_extras_config.h +extra-source-files: CHANGES.md + README.md + configure.ac + configure + config.mk.in + X11.buildinfo.in + include/HsX11Config.h.in + include/HsXlib.h + include/XlibExtras.h + include/X11_extras_config.h.in + include/HsAllKeysyms.h +cabal-version: >= 1.10 -flag smaller_base - description: Build with the even smaller base. +source-repository head + type: git + location: https://github.com/xmonad/X11 +flag pedantic + description: Be pedantic (-Werror and the like) + default: False + manual: True + library - exposed-modules: - Graphics.X11, - Graphics.X11.Types, - Graphics.X11.Xlib, - Graphics.X11.Xlib.Atom, - Graphics.X11.Xlib.Color, - Graphics.X11.Xlib.Context, - Graphics.X11.Xlib.Cursor, - Graphics.X11.Xlib.Display, - Graphics.X11.Xlib.Event, - Graphics.X11.Xlib.Font, - Graphics.X11.Xlib.Misc, - Graphics.X11.Xlib.Region, - Graphics.X11.Xlib.Screen, - Graphics.X11.Xlib.Types, - Graphics.X11.Xlib.Window, - Graphics.X11.Xlib.Image, - Graphics.X11.Xlib.Extras, - Graphics.X11.Xinerama - Graphics.X11.ExtraTypes, - Graphics.X11.ExtraTypes.AP, - Graphics.X11.ExtraTypes.DEC, - Graphics.X11.ExtraTypes.HP, - Graphics.X11.ExtraTypes.Sun - Graphics.X11.ExtraTypes.XF86, - Graphics.X11.ExtraTypes.XorgDefault - c-sources: - cbits/fdset.c, - cbits/auxiliaries.c, - cbits/XUtils.c - extensions: ForeignFunctionInterface, CPP - extra-libraries: "X11" - include-dirs: include + exposed-modules: Graphics.X11 + Graphics.X11.ExtraTypes + Graphics.X11.ExtraTypes.AP + Graphics.X11.ExtraTypes.DEC + Graphics.X11.ExtraTypes.HP + Graphics.X11.ExtraTypes.Sun + Graphics.X11.ExtraTypes.XF86 + Graphics.X11.ExtraTypes.XorgDefault + Graphics.X11.Types + Graphics.X11.XScreenSaver + Graphics.X11.Xinerama + Graphics.X11.Xlib + Graphics.X11.Xlib.Atom + Graphics.X11.Xlib.Color + Graphics.X11.Xlib.Context + Graphics.X11.Xlib.Cursor + Graphics.X11.Xlib.Display + Graphics.X11.Xlib.Event + Graphics.X11.Xlib.Extras + Graphics.X11.Xlib.Font + Graphics.X11.Xlib.Image + Graphics.X11.Xlib.Misc + Graphics.X11.Xlib.Region + Graphics.X11.Xlib.Screen + Graphics.X11.Xlib.Types + Graphics.X11.Xlib.Window + Graphics.X11.Xrandr + other-modules: Graphics.X11.Xlib.Internal + build-depends: base == 4.*, data-default-class == 0.1.* + default-language: Haskell98 + default-extensions: CPP + ForeignFunctionInterface + extra-libraries: X11, Xrandr, Xext + c-sources: cbits/fdset.c, cbits/auxiliaries.c, cbits/XUtils.c includes: HsXlib.h, HsAllKeysyms.h install-includes: HsXlib.h, XlibExtras.h, HsAllKeysyms.h - if flag(smaller_base) - build-depends: base >= 4 && < 5, syb - else - build-depends: base >= 3 && < 4 + include-dirs: include ghc-options: -funbox-strict-fields -Wall -fno-warn-unused-binds - ghc-prof-options: -prof -auto-all + + if flag(pedantic) + ghc-options: -Werror diff --git a/configure b/configure --- a/configure +++ b/configure @@ -1,13 +1,11 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.68 for Haskell X11 package 1.4.6. +# Generated by GNU Autoconf 2.69 for Haskell X11 package 1.4.6. # # Report bugs to . # # -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, -# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software -# Foundation, Inc. +# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation @@ -136,6 +134,31 @@ # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH +# Use a proper internal environment variable to ensure we don't fall + # into an infinite loop, continuously re-executing ourselves. + if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then + _as_can_reexec=no; export _as_can_reexec; + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +as_fn_exit 255 + fi + # We don't want this to propagate to other subprocesses. + { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh @@ -169,7 +192,8 @@ else exitcode=1; echo positional parameters were not saved. fi -test x\$exitcode = x0 || exit 1" +test x\$exitcode = x0 || exit 1 +test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && @@ -214,21 +238,25 @@ if test "x$CONFIG_SHELL" != x; then : - # We cannot yet assume a decent shell, so we have to provide a - # neutralization value for shells without unset; and this also - # works around shells that cannot unset nonexistent variables. - # Preserve -v and -x to the replacement shell. - BASH_ENV=/dev/null - ENV=/dev/null - (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV - export CONFIG_SHELL - case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; - esac - exec "$CONFIG_SHELL" $as_opts "$as_myself" ${1+"$@"} + export CONFIG_SHELL + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +exit 255 fi if test x$as_have_required = xno; then : @@ -331,6 +359,14 @@ } # as_fn_mkdir_p + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take @@ -452,6 +488,10 @@ chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } + # If we had to re-execute with $CONFIG_SHELL, we're ensured to have + # already done that, so ensure we don't try to do so again and fall + # in an infinite loop. This has already happened in practice. + _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). @@ -486,16 +526,16 @@ # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -p'. + # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -p' + as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else - as_ln_s='cp -p' + as_ln_s='cp -pR' fi else - as_ln_s='cp -p' + as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null @@ -507,28 +547,8 @@ as_mkdir_p=false fi -if test -x / >/dev/null 2>&1; then - as_test_x='test -x' -else - if ls -dL / >/dev/null 2>&1; then - as_ls_L_option=L - else - as_ls_L_option= - fi - as_test_x=' - eval sh -c '\'' - if test -d "$1"; then - test -d "$1/."; - else - case $1 in #( - -*)set "./$1";; - esac; - case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( - ???[sx]*):;;*)false;;esac;fi - '\'' sh - ' -fi -as_executable_p=$as_test_x +as_test_x='test -x' +as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" @@ -604,6 +624,7 @@ ac_subst_vars='LTLIBOBJS LIBOBJS +X_LIBRARIES EXTRA_LIBRARIES EGREP GREP @@ -641,6 +662,7 @@ docdir oldincludedir includedir +runstatedir localstatedir sharedstatedir sysconfdir @@ -716,6 +738,7 @@ sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' +runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' @@ -968,6 +991,15 @@ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; + -runstatedir | --runstatedir | --runstatedi | --runstated \ + | --runstate | --runstat | --runsta | --runst | --runs \ + | --run | --ru | --r) + ac_prev=runstatedir ;; + -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ + | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ + | --run=* | --ru=* | --r=*) + runstatedir=$ac_optarg ;; + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ @@ -1105,7 +1137,7 @@ for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir + libdir localedir mandir runstatedir do eval ac_val=\$$ac_var # Remove trailing slashes. @@ -1133,8 +1165,6 @@ if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe - $as_echo "$as_me: WARNING: if you wanted to set the --build type, don't use --host. - If a cross compiler is detected then cross compile mode will be used" >&2 elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi @@ -1260,6 +1290,7 @@ --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] @@ -1381,9 +1412,9 @@ if $ac_init_version; then cat <<\_ACEOF Haskell X11 package configure 1.4.6 -generated by GNU Autoconf 2.68 +generated by GNU Autoconf 2.69 -Copyright (C) 2010 Free Software Foundation, Inc. +Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF @@ -1496,7 +1527,7 @@ test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext + test -x conftest$ac_exeext }; then : ac_retval=0 else @@ -1750,7 +1781,7 @@ running configure, to aid debugging if configure makes a mistake. It was created by Haskell X11 package $as_me 1.4.6, which was -generated by GNU Autoconf 2.68. Invocation command line was +generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ @@ -2140,7 +2171,7 @@ IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -2180,7 +2211,7 @@ IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -2233,7 +2264,7 @@ IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}cc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -2274,7 +2305,7 @@ IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue @@ -2332,7 +2363,7 @@ IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -2376,7 +2407,7 @@ IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 @@ -2822,8 +2853,7 @@ /* end confdefs.h. */ #include #include -#include -#include +struct stat; /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); @@ -3816,7 +3846,7 @@ for ac_prog in grep ggrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" - { test -f "$ac_path_GREP" && $as_test_x "$ac_path_GREP"; } || continue + as_fn_executable_p "$ac_path_GREP" || continue # Check for GNU ac_path_GREP and select it if it is found. # Check for GNU $ac_path_GREP case `"$ac_path_GREP" --version 2>&1` in @@ -3882,7 +3912,7 @@ for ac_prog in egrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" - { test -f "$ac_path_EGREP" && $as_test_x "$ac_path_EGREP"; } || continue + as_fn_executable_p "$ac_path_EGREP" || continue # Check for GNU ac_path_EGREP and select it if it is found. # Check for GNU $ac_path_EGREP case `"$ac_path_EGREP" --version 2>&1` in @@ -4072,16 +4102,47 @@ done if test "$have_xinerama" = yes; then - EXTRA_LIBRARIES="extra-libraries: Xinerama Xext" + EXTRA_LIBRARIES="Xinerama Xext" else - EXTRA_LIBRARIES="" echo "WARNING: Xinerama headers not found. Building without Xinerama support" fi else - EXTRA_LIBRARIES="" echo "WARNING: Building without Xinerama support per user request" fi +for ac_header in X11/extensions/Xrandr.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "X11/extensions/Xrandr.h" "ac_cv_header_X11_extensions_Xrandr_h" "$ac_includes_default" +if test "x$ac_cv_header_X11_extensions_Xrandr_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_X11_EXTENSIONS_XRANDR_H 1 +_ACEOF + have_xrandr=yes +fi + +done + +if ! test "$have_xrandr" = yes; then + as_fn_error $? "X11/extensions/Xrandr.h (from libXrandr) is required" "$LINENO" 5 +fi + +for ac_header in X11/extensions/scrnsaver.h +do : + ac_fn_c_check_header_mongrel "$LINENO" "X11/extensions/scrnsaver.h" "ac_cv_header_X11_extensions_scrnsaver_h" "$ac_includes_default" +if test "x$ac_cv_header_X11_extensions_scrnsaver_h" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_X11_EXTENSIONS_SCRNSAVER_H 1 +_ACEOF + have_xscreensaver=yes +fi + +done + +if ! test "$have_xscreensaver" = yes; then + as_fn_error $? "X11/extensions/scrnsaver.h (from libXss) is required" "$LINENO" 5 +fi +EXTRA_LIBRARIES="Xss $EXTRA_LIBRARIES" + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to include X.org keysyms" >&5 $as_echo_n "checking whether to include X.org keysyms... " >&6; } @@ -4229,6 +4290,9 @@ +X_LIBRARIES="$x_libraries" + + ac_config_files="$ac_config_files config.mk X11.buildinfo" cat >confcache <<\_ACEOF @@ -4638,16 +4702,16 @@ # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -p'. + # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -p' + as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else - as_ln_s='cp -p' + as_ln_s='cp -pR' fi else - as_ln_s='cp -p' + as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null @@ -4707,29 +4771,17 @@ as_mkdir_p=false fi -if test -x / >/dev/null 2>&1; then - as_test_x='test -x' -else - if ls -dL / >/dev/null 2>&1; then - as_ls_L_option=L - else - as_ls_L_option= - fi - as_test_x=' - eval sh -c '\'' - if test -d "$1"; then - test -d "$1/."; - else - case $1 in #( - -*)set "./$1";; - esac; - case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( - ???[sx]*):;;*)false;;esac;fi - '\'' sh - ' -fi -as_executable_p=$as_test_x +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +as_test_x='test -x' +as_executable_p=as_fn_executable_p + # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" @@ -4750,7 +4802,7 @@ # values after options handling. ac_log=" This file was extended by Haskell X11 package $as_me 1.4.6, which was -generated by GNU Autoconf 2.68. Invocation command line was +generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS @@ -4812,10 +4864,10 @@ ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ Haskell X11 package config.status 1.4.6 -configured by $0, generated by GNU Autoconf 2.68, +configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" -Copyright (C) 2010 Free Software Foundation, Inc. +Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." @@ -4903,7 +4955,7 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then - set X '$SHELL' '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion + set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -9,7 +9,7 @@ # Safety check: Ensure that we are in the correct source directory. AC_CONFIG_SRCDIR([include/HsXlib.h]) -AC_CONFIG_HEADERS([include/HsX11Config.h include/X11_extras_config.h]) +AC_CONFIG_HEADERS([include/HsX11Config.h include/X11_extras_config.h]) # Check for X11 include paths and libraries AC_PATH_XTRA @@ -63,16 +63,25 @@ if test "$with_xinerama" = yes; then AC_CHECK_HEADERS([X11/extensions/Xinerama.h], [have_xinerama=yes]) if test "$have_xinerama" = yes; then - EXTRA_LIBRARIES="extra-libraries: Xinerama Xext" + EXTRA_LIBRARIES="Xinerama Xext" else - EXTRA_LIBRARIES="" echo "WARNING: Xinerama headers not found. Building without Xinerama support" fi else - EXTRA_LIBRARIES="" echo "WARNING: Building without Xinerama support per user request" fi +AC_CHECK_HEADERS([X11/extensions/Xrandr.h], [have_xrandr=yes]) +if ! test "$have_xrandr" = yes; then + AC_MSG_ERROR([X11/extensions/Xrandr.h (from libXrandr) is required]) +fi + +AC_CHECK_HEADERS([X11/extensions/scrnsaver.h], [have_xscreensaver=yes]) +if ! test "$have_xscreensaver" = yes; then + AC_MSG_ERROR([X11/extensions/scrnsaver.h (from libXss) is required]) +fi +EXTRA_LIBRARIES="Xss $EXTRA_LIBRARIES" + AC_MSG_CHECKING([whether to include X.org keysyms]) AC_ARG_WITH(xorg-keysym, AS_HELP_STRING([--without-xorg-keysym], [do not build X.org keysym support]), @@ -125,6 +134,9 @@ AC_SUBST([EXTRA_LIBRARIES]) + +X_LIBRARIES="$x_libraries" +AC_SUBST([X_LIBRARIES]) AC_CONFIG_FILES([config.mk X11.buildinfo]) AC_OUTPUT diff --git a/include/HsX11Config.h.in b/include/HsX11Config.h.in --- a/include/HsX11Config.h.in +++ b/include/HsX11Config.h.in @@ -36,8 +36,14 @@ /* Define to 1 if you have the header file. */ #undef HAVE_X11_DECKEYSYM_H +/* Define to 1 if you have the header file. */ +#undef HAVE_X11_EXTENSIONS_SCRNSAVER_H + /* Define to 1 if you have the header file. */ #undef HAVE_X11_EXTENSIONS_XINERAMA_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_X11_EXTENSIONS_XRANDR_H /* Define to 1 if you have the header file. */ #undef HAVE_X11_HPKEYSYM_H diff --git a/include/HsXlib.h b/include/HsXlib.h --- a/include/HsXlib.h +++ b/include/HsXlib.h @@ -18,10 +18,13 @@ #include #include +#include +#include + /* Xutil.h overrides some functions with macros. * In recent versions of X this can be turned off with * - * #define XUTIL_DEFINE_FUNCTIONS + * #define XUTIL_DEFINE_FUNCTIONS * * before the #include, but this doesn't work with older versions. * As a workaround, we undef the macros here. Note that this is only diff --git a/include/XlibExtras.h b/include/XlibExtras.h --- a/include/XlibExtras.h +++ b/include/XlibExtras.h @@ -17,6 +17,9 @@ #include #include +#include +#include + /* Xutil.h overrides some functions with macros. * In recent versions of X this can be turned off with * #define XUTIL_DEFINE_FUNCTIONS