diff --git a/Readme.md b/Readme.md new file mode 100644 --- /dev/null +++ b/Readme.md @@ -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 +``` diff --git a/bindings-wlc.cabal b/bindings-wlc.cabal --- a/bindings-wlc.cabal +++ b/bindings-wlc.cabal @@ -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 diff --git a/src/Bindings/WLC.hs b/src/Bindings/WLC.hs --- a/src/Bindings/WLC.hs +++ b/src/Bindings/WLC.hs @@ -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 diff --git a/src/Bindings/WLC/Core.hsc b/src/Bindings/WLC/Core.hsc --- a/src/Bindings/WLC/Core.hsc +++ b/src/Bindings/WLC/Core.hsc @@ -2,7 +2,7 @@ #include {-| -Module : Bindings.WLC.WLC +Module : Bindings.WLC.Core Description : Core WLC Copyright : (c) Ashley Towns 2016 License : BSD3 diff --git a/src/System/WLC.hs b/src/System/WLC.hs --- a/src/System/WLC.hs +++ b/src/System/WLC.hs @@ -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 diff --git a/src/System/WLC/Core.hs b/src/System/WLC/Core.hs --- a/src/System/WLC/Core.hs +++ b/src/System/WLC/Core.hs @@ -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 diff --git a/src/System/WLC/Geometry.hs b/src/System/WLC/Geometry.hs --- a/src/System/WLC/Geometry.hs +++ b/src/System/WLC/Geometry.hs @@ -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)