packages feed

bindings-wlc 0.1.0.1 → 0.1.0.2

raw patch · 7 files changed

+178/−310 lines, 7 files

Files

+ Readme.md view
@@ -0,0 +1,34 @@+# bindings-wlc++WIP bindings against libwlc++## Using Bindings.WLC+Low level bindings to WLC via bindings-dsl++```haskell+do+  logger <- mk'log_handler_cb (\_ -> print)+  c'wlc_log_set_handler logger++  c'wlc_init2++  created_cb <- mk'output_created_cb (\output -> do+    putStrLn "Output created"+    return True)+  c'wlc_set_output_created_cb created_cb++  c'wlc_run+```++## Using System.WLC+System.WLC builds on Binding.WLC++```haskell+do+  initialize+  logHandler (\tag text -> putStrLn $ stringTag tag ++ " " ++ text) -- Log all the things+  dispatchEvent (PointerMotion (\_ _ ptr -> do pointerSetPosition ptr; return True)) -- Allow mouse movement+  dispatchEvent (ViewCreated (\view -> do viewBringToFront view; viewFocus view; return True)) -- Pop views to the front+  dispatchEvent (CompositorReady $ exec "weston-terminal" []) -- Launch weston-terminal when we're ready+  run+```
bindings-wlc.cabal view
@@ -1,7 +1,7 @@ name:                bindings-wlc-version:             0.1.0.1+version:             0.1.0.2 synopsis:            Bindings against the wlc library-description:         Please see README.md+description:         Please see Readme.md homepage:            http://github.com/aktowns/bindings-wlc#readme license:             BSD3 license-file:        LICENSE@@ -10,7 +10,7 @@ copyright:           2016 Ashley Towns category:            FFI build-type:          Simple--- extra-source-files:+extra-source-files:  Readme.md cabal-version:       >=1.10  library
src/Bindings/WLC.hs view
@@ -1,3 +1,14 @@+{-|+Module      : Bindings.WLC+Description : WLC Bindings+Copyright   : (c) Ashley Towns 2016+License     : BSD3+Maintainer  : mail@ashleytowns.id.au+Stability   : experimental+Portability : POSIX++Provides bindings to the low level WLC API's+-} module Bindings.WLC where  import Bindings.WLC.Defines
src/Bindings/WLC/Core.hsc view
@@ -2,7 +2,7 @@ #include <wlc/wlc.h>  {-|-Module      : Bindings.WLC.WLC+Module      : Bindings.WLC.Core Description : Core WLC Copyright   : (c) Ashley Towns 2016 License     : BSD3
src/System/WLC.hs view
@@ -1,4 +1,16 @@+{-|+Module      : System.WLC+Description : WLC Abstractions+Copyright   : (c) Ashley Towns 2016+License     : BSD3+Maintainer  : mail@ashleytowns.id.au+Stability   : experimental+Portability : POSIX++Provides abstractions over the low level WLC API's+-} module System.WLC where -import System.WLC.Geometry import System.WLC.Core+import System.WLC.Geometry+import System.WLC.Types
src/System/WLC/Core.hs view
@@ -1,10 +1,22 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-|+Module      : System.WLC.Core+Description : Core WLC+Copyright   : (c) Ashley Towns 2016+License     : BSD3+Maintainer  : mail@ashleytowns.id.au+Stability   : experimental+Portability : POSIX++Provides abstractions over the low level bindings to the core WLC API.+-} module System.WLC.Core where -import Bindings.WLC.Defines import Bindings.WLC.Core+import System.WLC.Types import System.WLC.Geometry import System.WLC.Utilities+import System.WLC.Internal.Types+ import Data.Word(Word8, Word32) import Control.Monad(liftM2) import Foreign.Ptr(nullPtr)@@ -15,292 +27,37 @@ import Data.Convertible.Base import Data.Convertible.Instances.C --- Wrappers around the type synonyms so we can add the Primitive instances.-newtype WlcLogType       = WlcLogType C'wlc_log_type deriving (Show)-newtype WlcBackendType   = WlcBackendType C'wlc_backend_type deriving (Show)-newtype WlcEventBit      = WlcEventBit C'wlc_event_bit deriving (Show)-newtype WlcViewStateBit  = WlcViewStateBit { getViewStateBit :: C'wlc_view_state_bit } deriving (Show)-newtype WlcViewTypeBit   = WlcViewTypeBit { getViewTypeBit :: C'wlc_view_type_bit } deriving (Show)-newtype WlcResizeEdge    = WlcResizeEdge C'wlc_resize_edge deriving (Show)-newtype WlcModifierBit   = WlcModifierBit { getModifierBit :: C'wlc_modifier_bit } deriving (Show)-newtype WlcLedBit        = WlcLedBit { getLedBit :: C'wlc_led_bit } deriving (Show)-newtype WlcKeyState      = WlcKeyState C'wlc_key_state deriving (Show)-newtype WlcButtonState   = WlcButtonState C'wlc_button_state deriving (Show)-newtype WlcScrollAxisBit = WlcScrollAxisBit C'wlc_scroll_axis_bit deriving (Show)-newtype WlcTouchType     = WlcTouchType C'wlc_touch_type deriving (Show)--data LogType = LogInfo-             | LogWarn-             | LogError-             | LogWayland deriving (Eq, Show)--instance Primitive WlcLogType LogType where-    fromPrimitive (WlcLogType x)-        | x == c'WLC_LOG_INFO = LogInfo-        | x == c'WLC_LOG_WARN = LogWarn-        | x == c'WLC_LOG_ERROR = LogError-        | x == c'WLC_LOG_WAYLAND = LogWayland-        | otherwise = error $ "unexpected logger given: " ++ show x--    toPrimitive LogInfo = WlcLogType c'WLC_LOG_INFO-    toPrimitive LogWarn = WlcLogType c'WLC_LOG_WARN-    toPrimitive LogError = WlcLogType c'WLC_LOG_ERROR-    toPrimitive LogWayland = WlcLogType c'WLC_LOG_WAYLAND--data BackendType = BackendNone-                 | BackendDRM-                 | BackendX11 deriving (Eq, Show)--instance Primitive WlcBackendType BackendType where-    fromPrimitive (WlcBackendType x)-        | x == c'WLC_BACKEND_NONE = BackendNone-        | x == c'WLC_BACKEND_DRM = BackendDRM-        | x == c'WLC_BACKEND_X11 = BackendX11-        | otherwise = error $ "unexpected backend given: " ++ show x--    toPrimitive BackendNone = WlcBackendType c'WLC_BACKEND_NONE-    toPrimitive BackendDRM = WlcBackendType c'WLC_BACKEND_DRM-    toPrimitive BackendX11 = WlcBackendType c'WLC_BACKEND_X11--data EventBit = EventReadable-              | EventWritable-              | EventHangup-              | EventError deriving (Eq, Show)--instance Primitive WlcEventBit EventBit where-    fromPrimitive (WlcEventBit x)-        | x == c'WLC_EVENT_READABLE = EventReadable-        | x == c'WLC_EVENT_WRITABLE = EventWritable-        | x == c'WLC_EVENT_HANGUP = EventHangup-        | x == c'WLC_EVENT_ERROR = EventError-        | otherwise = error $ "unexpected event bit given: " ++ show x--    toPrimitive EventReadable = WlcEventBit c'WLC_EVENT_READABLE-    toPrimitive EventWritable = WlcEventBit c'WLC_EVENT_WRITABLE-    toPrimitive EventHangup = WlcEventBit c'WLC_EVENT_HANGUP-    toPrimitive EventError = WlcEventBit c'WLC_EVENT_ERROR--data ViewState = ViewMaximized-               | ViewFullscreen-               | ViewResizing-               | ViewMoving-               | ViewActivated deriving (Eq, Show)--instance Primitive WlcViewStateBit ViewState where-    fromPrimitive (WlcViewStateBit x)-        | x == c'WLC_BIT_MAXIMIZED = ViewMaximized-        | x == c'WLC_BIT_FULLSCREEN = ViewFullscreen-        | x == c'WLC_BIT_RESIZING = ViewResizing-        | x == c'WLC_BIT_MOVING = ViewMoving-        | x == c'WLC_BIT_ACTIVATED = ViewActivated-        | otherwise = error $ "unexpected view state bit given: " ++ show x--    toPrimitive ViewMaximized = WlcViewStateBit c'WLC_BIT_MAXIMIZED-    toPrimitive ViewFullscreen = WlcViewStateBit c'WLC_BIT_FULLSCREEN-    toPrimitive ViewResizing = WlcViewStateBit c'WLC_BIT_RESIZING-    toPrimitive ViewMoving = WlcViewStateBit c'WLC_BIT_MOVING-    toPrimitive ViewActivated = WlcViewStateBit c'WLC_BIT_ACTIVATED--data ViewType = ViewOverrideRedirect-              | ViewUnmanaged-              | ViewSplash-              | ViewModal-              | ViewPopup deriving (Eq, Show)--instance Primitive WlcViewTypeBit ViewType where-    fromPrimitive (WlcViewTypeBit x)-        | x == c'WLC_BIT_OVERRIDE_REDIRECT = ViewOverrideRedirect-        | x == c'WLC_BIT_UNMANAGED = ViewUnmanaged-        | x == c'WLC_BIT_SPLASH = ViewSplash-        | x == c'WLC_BIT_MODAL = ViewModal-        | x == c'WLC_BIT_POPUP = ViewPopup-        | otherwise = error $ "unexpected view type bit given: " ++ show x--    toPrimitive ViewOverrideRedirect = WlcViewTypeBit c'WLC_BIT_OVERRIDE_REDIRECT-    toPrimitive ViewUnmanaged = WlcViewTypeBit c'WLC_BIT_UNMANAGED-    toPrimitive ViewSplash = WlcViewTypeBit c'WLC_BIT_SPLASH-    toPrimitive ViewModal = WlcViewTypeBit c'WLC_BIT_MODAL-    toPrimitive ViewPopup = WlcViewTypeBit c'WLC_BIT_POPUP--data ResizeEdge = EdgeNone-                | EdgeTop-                | EdgeBottom-                | EdgeLeft-                | EdgeTopLeft-                | EdgeBottomLeft-                | EdgeRight-                | EdgeTopRight-                | EdgeBottomRight deriving (Eq, Show)--instance Primitive WlcResizeEdge ResizeEdge where-    fromPrimitive (WlcResizeEdge x)-        | x == c'WLC_RESIZE_EDGE_NONE = EdgeNone-        | x == c'WLC_RESIZE_EDGE_TOP = EdgeTop-        | x == c'WLC_RESIZE_EDGE_BOTTOM = EdgeBottom-        | x == c'WLC_RESIZE_EDGE_LEFT = EdgeLeft-        | x == c'WLC_RESIZE_EDGE_TOP_LEFT = EdgeTopLeft-        | x == c'WLC_RESIZE_EDGE_BOTTOM_LEFT = EdgeBottomLeft-        | x == c'WLC_RESIZE_EDGE_RIGHT = EdgeRight-        | x == c'WLC_RESIZE_EDGE_TOP_RIGHT = EdgeTopRight-        | x == c'WLC_RESIZE_EDGE_BOTTOM_RIGHT = EdgeBottomRight-        | otherwise = error $ "unexpected resize edge bit given: " ++ show x--    toPrimitive EdgeNone = WlcResizeEdge c'WLC_RESIZE_EDGE_NONE-    toPrimitive EdgeTop = WlcResizeEdge c'WLC_RESIZE_EDGE_TOP-    toPrimitive EdgeBottom = WlcResizeEdge c'WLC_RESIZE_EDGE_BOTTOM-    toPrimitive EdgeLeft = WlcResizeEdge c'WLC_RESIZE_EDGE_LEFT-    toPrimitive EdgeTopLeft = WlcResizeEdge c'WLC_RESIZE_EDGE_TOP_LEFT-    toPrimitive EdgeBottomLeft = WlcResizeEdge c'WLC_RESIZE_EDGE_BOTTOM_LEFT-    toPrimitive EdgeRight = WlcResizeEdge c'WLC_RESIZE_EDGE_RIGHT-    toPrimitive EdgeTopRight = WlcResizeEdge c'WLC_RESIZE_EDGE_TOP_RIGHT-    toPrimitive EdgeBottomRight = WlcResizeEdge c'WLC_RESIZE_EDGE_BOTTOM_RIGHT--data Modifier = Shift-              | Caps-              | CTRL-              | Alt-              | Mod2-              | Mod3-              | ModLogo-              | Mod5 deriving (Eq, Show)--instance Primitive WlcModifierBit Modifier where-    fromPrimitive (WlcModifierBit x)-        | x == c'WLC_BIT_MOD_SHIFT = Shift-        | x == c'WLC_BIT_MOD_CAPS = Caps-        | x == c'WLC_BIT_MOD_CTRL = CTRL-        | x == c'WLC_BIT_MOD_ALT = Alt-        | x == c'WLC_BIT_MOD_MOD2 = Mod2-        | x == c'WLC_BIT_MOD_MOD3 = Mod3-        | x == c'WLC_BIT_MOD_LOGO = ModLogo-        | x == c'WLC_BIT_MOD_MOD5 = Mod5-        | otherwise = error $ "unexpected modifier bit given: " ++ show x--    toPrimitive Shift = WlcModifierBit c'WLC_BIT_MOD_SHIFT-    toPrimitive Caps = WlcModifierBit c'WLC_BIT_MOD_CAPS-    toPrimitive CTRL = WlcModifierBit c'WLC_BIT_MOD_CTRL-    toPrimitive Alt = WlcModifierBit c'WLC_BIT_MOD_ALT-    toPrimitive Mod2 = WlcModifierBit c'WLC_BIT_MOD_MOD2-    toPrimitive Mod3 = WlcModifierBit c'WLC_BIT_MOD_MOD3-    toPrimitive ModLogo = WlcModifierBit c'WLC_BIT_MOD_LOGO-    toPrimitive Mod5 = WlcModifierBit c'WLC_BIT_MOD_MOD5--data Led = LedNum-         | LedCaps-         | LedScroll deriving (Eq, Show)--instance Primitive WlcLedBit Led where-    fromPrimitive (WlcLedBit x)-        | x == c'WLC_BIT_LED_NUM = LedNum-        | x == c'WLC_BIT_LED_CAPS = LedCaps-        | x == c'WLC_BIT_LED_SCROLL = LedScroll-        | otherwise = error $ "unexpected led bit given: " ++ show x--    toPrimitive LedNum = WlcLedBit c'WLC_BIT_LED_NUM-    toPrimitive LedCaps = WlcLedBit c'WLC_BIT_LED_CAPS-    toPrimitive LedScroll = WlcLedBit c'WLC_BIT_LED_SCROLL--data KeyState = KeyReleased | KeyPressed deriving (Eq, Show)--instance Primitive WlcKeyState KeyState where-    fromPrimitive (WlcKeyState x)-        | x == c'WLC_KEY_STATE_RELEASED = KeyReleased-        | x == c'WLC_KEY_STATE_PRESSED = KeyPressed--    toPrimitive KeyReleased = WlcKeyState c'WLC_KEY_STATE_RELEASED-    toPrimitive KeyPressed = WlcKeyState c'WLC_KEY_STATE_PRESSED--data ButtonState = ButtonReleased | ButtonPressed deriving (Eq, Show)--instance Primitive WlcButtonState ButtonState where-    fromPrimitive (WlcButtonState x)-        | x == c'WLC_BUTTON_STATE_RELEASED = ButtonReleased-        | x == c'WLC_BUTTON_STATE_PRESSED = ButtonPressed--    toPrimitive ButtonReleased = WlcButtonState c'WLC_BUTTON_STATE_RELEASED-    toPrimitive ButtonPressed = WlcButtonState c'WLC_BUTTON_STATE_PRESSED--data ScrollAxis = AxisVertical | AxisHorizontal deriving (Eq, Show)--instance Primitive WlcScrollAxisBit ScrollAxis where-    fromPrimitive (WlcScrollAxisBit x)-        | x == c'WLC_SCROLL_AXIS_VERTICAL = AxisVertical-        | x == c'WLC_SCROLL_AXIS_HORIZONTAL = AxisHorizontal--    toPrimitive AxisVertical = WlcScrollAxisBit c'WLC_SCROLL_AXIS_VERTICAL-    toPrimitive AxisHorizontal = WlcScrollAxisBit c'WLC_SCROLL_AXIS_HORIZONTAL--data TouchType = TouchDown-               | TouchUp-               | TouchMotion-               | TouchFrame-               | TouchCancel deriving (Eq, Show)--instance Primitive WlcTouchType TouchType where-    fromPrimitive (WlcTouchType x)-        | x == c'WLC_TOUCH_DOWN = TouchDown-        | x == c'WLC_TOUCH_UP = TouchUp-        | x == c'WLC_TOUCH_MOTION = TouchMotion-        | x == c'WLC_TOUCH_FRAME = TouchFrame-        | x == c'WLC_TOUCH_CANCEL = TouchCancel--    toPrimitive TouchDown = WlcTouchType c'WLC_TOUCH_DOWN-    toPrimitive TouchUp = WlcTouchType c'WLC_TOUCH_UP-    toPrimitive TouchMotion = WlcTouchType c'WLC_TOUCH_MOTION-    toPrimitive TouchFrame = WlcTouchType c'WLC_TOUCH_FRAME-    toPrimitive TouchCancel = WlcTouchType c'WLC_TOUCH_CANCEL--data Modifiers = Modifiers { leds :: Led, mods :: Modifier }--instance Primitive C'wlc_modifiers Modifiers where-    fromPrimitive C'wlc_modifiers { c'wlc_modifiers'leds = leds, c'wlc_modifiers'mods = mods } =-        Modifiers { leds = fromPrimitive $ WlcLedBit leds, mods = fromPrimitive $ WlcModifierBit mods }-    toPrimitive Modifiers { leds = leds, mods = mods } =-        C'wlc_modifiers {-          c'wlc_modifiers'leds = getLedBit $ toPrimitive leds,-          c'wlc_modifiers'mods = getModifierBit $ toPrimitive mods }--newtype Output = Output { getOutputHandle :: C'wlc_handle }-newtype View = View { getViewHandle :: C'wlc_handle }--tryGetView :: C'wlc_handle -> Maybe View-tryGetView 0 = Nothing-tryGetView x = Just $ View x--tryGetOutput :: C'wlc_handle -> Maybe Output-tryGetOutput 0 = Nothing-tryGetOutput x = Just $ Output x--data Callback = OutputCreated (Output -> IO Bool)-              | OutputDestroyed (Output -> IO ())-              | OutputFocus (Output -> Bool -> IO ())-              | OutputResolution (Output -> Size -> Size -> IO ())-              | OutputRenderPre (Output -> IO ())-              | OutputRenderPost (Output -> IO ())+-- * Callback API -              | ViewCreated (View -> IO Bool)-              | ViewDestroyed (View -> IO ())-              | ViewFocus (View -> Bool -> IO ())-              | ViewMoveToOutput (View -> Output -> Output -> IO ())-              | ViewRequestGeometry (View -> Geometry -> IO ())-              | ViewRequestState (View -> ViewState -> Bool -> IO ())-              | ViewRequestMove (View -> Point -> IO ())-              | ViewRequestResize (View -> ResizeEdge -> Point -> IO ())-              | ViewRenderPre (View -> IO ())-              | ViewRenderPost (View -> IO ())+-- | Available callbacks to be handed to 'dispatchEvent'+data Callback = OutputCreated (Output -> IO Bool)                     -- ^ Output was created. Return false if you want to destroy the output.+              | OutputDestroyed (Output -> IO ())                     -- ^ Output was destroyed.+              | OutputFocus (Output -> Bool -> IO ())                 -- ^ Output got or lost focus.+              | OutputResolution (Output -> Size -> Size -> IO ())    -- ^ Output resolution changed.+              | OutputRenderPre (Output -> IO ())                     -- ^ Output pre render hook.+              | OutputRenderPost (Output -> IO ())                    -- ^ Output post render hook. -              | KeyboardKey (Maybe View -> Int -> Modifiers -> Int -> KeyState -> IO Bool)-              | PointerButton (Maybe View -> Int -> Modifiers -> Int -> ButtonState -> Point -> IO Bool)-              | PointerScroll (Maybe View -> Int -> Modifiers -> ScrollAxis -> Double -> IO Bool)-              | PointerMotion (Maybe View -> Int -> Point -> IO Bool)-              | Touch (Maybe View -> Int -> Modifiers -> TouchType -> Int -> Point -> IO Bool)+              | ViewCreated (View -> IO Bool)                         -- ^ View was created. Return false if you want to destroy the view.+              | ViewDestroyed (View -> IO ())                         -- ^ View was destroyed.+              | ViewFocus (View -> Bool -> IO ())                     -- ^ View got or lost focus.+              | ViewMoveToOutput (View -> Output -> Output -> IO ())  -- ^ View was moved to output.+              | ViewRequestGeometry (View -> Geometry -> IO ())       -- ^ Request to set given geometry for view. Apply using 'viewSetGeometry' to agree.+              | ViewRequestState (View -> ViewState -> Bool -> IO ()) -- ^ Request to disable or enable the given state for view. Apply using 'viewSetViewState' to agree.+              | ViewRequestMove (View -> Point -> IO ())              -- ^ Request to move itself. Start a interactive move to agree.+              | ViewRequestResize (View -> ResizeEdge -> Point -> IO ()) -- ^ Request to resize itself with the given edges. Start a interactive resize to agree.+              | ViewRenderPre (View -> IO ())                         -- ^ View pre render hook.+              | ViewRenderPost (View -> IO ())                        -- ^ View post render hook. -              | CompositorReady (IO ())-              | CompositorTerminate (IO ())+              | KeyboardKey (Maybe View -> Int -> Modifiers -> Int -> KeyState -> IO Bool)                -- ^ Key event was triggered, view will be 'Nothing' if there was no focus. Return true to prevent sending the event to clients.+              | PointerButton (Maybe View -> Int -> Modifiers -> Int -> ButtonState -> Point -> IO Bool)  -- ^ Button event was triggered, view will be 'Nothing' if there was no focus. Return true to prevent sending the event to clients.+              | PointerScroll (Maybe View -> Int -> Modifiers -> ScrollAxis -> Double -> IO Bool)         -- ^ Scroll event was triggered, view will be 'Nothing' if there was no focus. Return true to prevent sending the event to clients.+              | PointerMotion (Maybe View -> Int -> Point -> IO Bool)                                     -- ^ Motion event was triggered, view will be 'Nothing' if there was no focus. Apply with 'pointerSetPosition' to agree. Return true to prevent sending the event to clients.+              | Touch (Maybe View -> Int -> Modifiers -> TouchType -> Int -> Point -> IO Bool)            -- ^ Touch event was triggered, view will be 'Nothing' if there was no focus. Return true to prevent sending the event to clients. -apply3 :: (e -> a) -> (f -> b) -> (g -> c) -> (a -> b -> c -> d) -> (e -> f -> g -> d)-apply3 a1 a2 a3 fn e f g = fn (a1 e) (a2 f) (a3 g)+              | CompositorReady (IO ())                               -- ^ Compositor is ready to accept clients.+              | CompositorTerminate (IO ())                           -- ^ Compositor is about to terminate +-- |Marshals the 'Callback' and applies it to the underlying library dispatchEvent :: Callback -> IO () dispatchEvent (OutputCreated cb) = mk'output_created_cb (cb . Output) >>= c'wlc_set_output_created_cb dispatchEvent (OutputDestroyed cb) = mk'output_destroyed_cb (cb . Output) >>= c'wlc_set_output_destroyed_cb@@ -357,95 +114,151 @@ dispatchEvent (CompositorReady cb) = mk'compositor_ready_cb cb >>= c'wlc_set_compositor_ready_cb dispatchEvent (CompositorTerminate cb) = mk'compositor_terminate_cb cb >>= c'wlc_set_compositor_terminate_cb -stringTag :: LogType -> String-stringTag LogInfo = "INFO"-stringTag LogWarn = "WARN"-stringTag LogError = "ERROR"-stringTag LogWayland = "WAYLAND"+-- * Core API +-- |Set log handler. Can be set before initialize. logHandler :: (LogType -> String -> IO ()) -> IO () logHandler cb = mk'log_handler_cb (\typ text -> do   str <- peekCString text   cb (fromPrimitive $ WlcLogType typ) str) >>= c'wlc_log_set_handler +-- |Initialize wlc. Returns false on failure.+--+-- Avoid running unverified code before 'initialize' as wlc compositor may be run with higher+-- privileges on non logind systems where compositor binary needs to be suid.+--+-- initialize's purpose is to initialize and drop privileges as soon as possible.+--+-- Callbacks should be set using 'dispatchEvent' before calling 'initialize',+-- failing to do so will cause any callback the init may trigger to not be called. initialize :: IO Bool initialize = c'wlc_init2 +-- |Terminate wlc. terminate :: IO () terminate = c'wlc_terminate +-- |Query backend wlc is using.+getBackendType :: IO BackendType+getBackendType = do+  backend <- c'wlc_get_backend_type+  return $ fromPrimitive (WlcBackendType backend)++-- |Exec program.+exec :: String -> [String] -> IO ()+exec app args = do+    let fullArgs = app : args+    putStrLn $ "Executing: " ++ app ++ " with " ++ show fullArgs+    convertedArgs <- mapM newCString fullArgs+    withCString app $ withArray0 nullPtr convertedArgs . c'wlc_exec+    mapM_ free convertedArgs++-- |Run event loop.+run :: IO ()+run = c'wlc_run++-- ** Output++-- |Get current visibility bitmask. outputGetMask :: Output -> IO Word32 outputGetMask (Output view) = convert <$> c'wlc_output_get_mask view +-- |Set visibility bitmask. outputSetMask :: Output -> Word32 -> IO () outputSetMask (Output view) mask = c'wlc_output_set_mask view (convert mask) +-- |Focus output. Pass zero for no focus. outputFocus :: Output -> IO () outputFocus (Output output) = c'wlc_output_focus output +-- ** View++-- |Focus view. Pass zero for no focus. viewFocus :: View -> IO () viewFocus (View view) = c'wlc_view_focus view +-- |Close 'View'. viewClose :: View -> IO () viewClose (View view) = c'wlc_view_close view +-- |Get current output. viewGetOutput :: View -> IO Output viewGetOutput (View view) = Output <$> c'wlc_view_get_output view +-- |Set output. Alternatively you can 'outputSetViews'. viewSetOutput :: View -> Output -> IO () viewSetOutput (View view) (Output output) = c'wlc_view_set_output view output +-- |Send behind everything. viewSendToBack :: View -> IO () viewSendToBack (View view) = c'wlc_view_send_to_back view +-- |Send below another 'View'. viewSendBelow :: View -> View -> IO () viewSendBelow (View view) (View other) = c'wlc_view_send_below view other +-- |Send above another 'View'. viewBringAbove :: View -> View -> IO () viewBringAbove (View view) (View other) = c'wlc_view_bring_above view other +-- |Bring to front of everything. viewBringToFront :: View -> IO () viewBringToFront (View view) = c'wlc_view_bring_to_front view +-- |Get current visibility bitmask. viewGetMask :: View -> IO Word32 viewGetMask (View view) = convert <$> c'wlc_view_get_mask view +-- |Set visibility bitmask. viewSetMask :: View -> Word32 -> IO () viewSetMask (View view) mask = c'wlc_view_set_mask view (convert mask) +-- |Get current geometry. (what client sees) viewGetGeometry :: View -> IO Geometry viewGetGeometry (View view) = do     geoPtr <- c'wlc_view_get_geometry view     Just geo <- fromPrimitivePtr geoPtr     return geo +-- |Get 'ViewType' bitfield. viewGetViewType :: View -> IO ViewType viewGetViewType (View view) = fromPrimitive . WlcViewTypeBit <$> c'wlc_view_get_type view +-- |Set 'ViewType' bit. Toggle indicates whether it is set or not. viewSetViewType :: View -> ViewType -> Bool -> IO () viewSetViewType (View view) vt = c'wlc_view_set_type view (getViewTypeBit $ toPrimitive vt) +-- |Get current 'ViewState' bitfield. viewGetViewState :: View -> IO ViewState viewGetViewState (View view) = fromPrimitive . WlcViewStateBit <$> c'wlc_view_get_state view +-- |Set 'ViewState' bit. Toggle indicates whether it is set or not. viewSetViewState :: View -> ViewState -> Bool -> IO () viewSetViewState (View view) vs = c'wlc_view_set_state view (getViewStateBit $ toPrimitive vs) +-- |Get parent 'View'. viewGetParent :: View -> IO (Maybe View) viewGetParent (View view) = tryGetView <$> c'wlc_view_get_parent view +-- |Set parent 'View'. viewSetParent :: View -> View -> IO () viewSetParent (View view) (View other) = c'wlc_view_set_parent view other +-- |Get 'View' title. viewGetTitle :: View -> IO String viewGetTitle (View view) = c'wlc_view_get_title view >>= peekCString +-- |Get class. (shell-surface only) viewGetClass :: View -> IO String viewGetClass (View view) = c'wlc_view_get_class view >>= peekCString +-- |Get app id. (xdg-surface only) viewGetAppId :: View -> IO String viewGetAppId (View view) = c'wlc_view_get_app_id view >>= peekCString +-- ** Input++-- |Get current pointer position. pointerGetPosition :: IO Point pointerGetPosition =     alloca (\point -> do@@ -453,22 +266,7 @@         Just pt <- fromPrimitivePtr point         return pt) +-- |Set current pointer position. pointerSetPosition :: Point -> IO () pointerSetPosition pt = with point c'wlc_pointer_set_position     where point = toPrimitive pt--getBackendType :: IO BackendType-getBackendType = do-  backend <- c'wlc_get_backend_type-  return $ fromPrimitive (WlcBackendType backend)--exec :: String -> [String] -> IO ()-exec app args = do-    let fullArgs = app : args-    putStrLn $ "Executing: " ++ app ++ " with " ++ show fullArgs-    convertedArgs <- mapM newCString fullArgs-    withCString app $ withArray0 nullPtr convertedArgs . c'wlc_exec-    mapM_ free convertedArgs--run :: IO ()-run = c'wlc_run
src/System/WLC/Geometry.hs view
@@ -1,4 +1,15 @@ {-# LANGUAGE MultiParamTypeClasses #-}+{-|+Module      : System.WLC.Geometry+Description : WLC Geometry+Copyright   : (c) Ashley Towns 2016+License     : BSD3+Maintainer  : mail@ashleytowns.id.au+Stability   : experimental+Portability : POSIX++Provides abstractions over the low level geometry WLC data types.+-} module System.WLC.Geometry where  import Foreign.Ptr(Ptr)@@ -9,7 +20,7 @@ import System.WLC.Utilities import Bindings.WLC.Geometry -+-- |Fixed 2D point data Point = Point { x :: Int, y :: Int }     deriving (Eq, Show, Ord) @@ -17,6 +28,7 @@     fromPrimitive C'wlc_point { c'wlc_point'x = x, c'wlc_point'y = y } = Point { x = convert x, y = convert y }     toPrimitive Point { x = x, y = y } = C'wlc_point { c'wlc_point'x = convert x, c'wlc_point'y = convert y } +-- |Fixed 2D size data Size = Size { w :: Word32, h :: Word32 }     deriving (Eq, Show, Ord) @@ -24,6 +36,7 @@     fromPrimitive C'wlc_size { c'wlc_size'w = w, c'wlc_size'h = h } = Size { w = convert w, h = convert h }     toPrimitive Size { w = w, h = h } = C'wlc_size { c'wlc_size'w = convert w, c'wlc_size'h = convert h } +-- |Fixed 2D point, size pair data Geometry = Geometry { origin :: Point, size :: Size }     deriving (Eq, Show, Ord)