module System.WLC.Core where
import Bindings.WLC
import System.WLC.Geometry
import System.WLC.Internal.Types
import System.WLC.Types
import System.WLC.Utilities (Primitive (..), apply3)
import Data.Convertible.Base
import Data.Convertible.Instances.C
import Data.Maybe (fromMaybe)
import Data.Word (Word32, Word8)
import Foreign.C.String (newCString, peekCString,
withCString)
import Foreign.C.Types (CSize (..))
import Foreign.Marshal.Alloc (alloca, free)
import Foreign.Marshal.Array (newArray, peekArray, withArray,
withArray0)
import Foreign.Marshal.Utils (with)
import Foreign.Ptr (nullPtr)
import Foreign.Storable (peek)
data Callback = OutputCreated (Output -> IO Bool)
| OutputDestroyed (Output -> IO ())
| OutputFocus (Output -> Bool -> IO ())
| OutputResolution (Output -> Size -> Size -> IO ())
| OutputRenderPre (Output -> IO ())
| OutputRenderPost (Output -> IO ())
| 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 ())
| 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)
| CompositorReady (IO ())
| CompositorTerminate (IO ())
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
dispatchEvent (OutputFocus cb) = mk'output_focus_cb (cb . Output) >>= c'wlc_set_output_focus_cb
dispatchEvent (OutputResolution cb) = mk'output_resolution_cb (\output fromPtr toPtr -> do
Just from <- fromPrimitivePtr fromPtr
Just to <- fromPrimitivePtr toPtr
cb (Output output) from to) >>= c'wlc_set_output_resolution_cb
dispatchEvent (OutputRenderPre cb) = mk'output_render_pre_cb (cb . Output) >>= c'wlc_set_output_render_pre_cb
dispatchEvent (OutputRenderPost cb) = mk'output_render_post_cb (cb . Output) >>= c'wlc_set_output_render_post_cb
dispatchEvent (ViewCreated cb) = mk'view_created_cb (cb . View) >>= c'wlc_set_view_created_cb
dispatchEvent (ViewDestroyed cb) = mk'view_destroyed_cb (cb . View) >>= c'wlc_set_view_destroyed_cb
dispatchEvent (ViewFocus cb) = mk'view_focus_cb (cb . View) >>= c'wlc_set_view_focus_cb
dispatchEvent (ViewMoveToOutput cb) =
mk'view_move_to_output_cb (apply3 View Output Output cb) >>= c'wlc_set_view_move_to_output_cb
dispatchEvent (ViewRequestGeometry cb) = mk'view_request_geometry_cb (\view geometryPtr -> do
Just geometry <- fromPrimitivePtr geometryPtr
cb (View view) geometry) >>= c'wlc_set_view_request_geometry_cb
dispatchEvent (ViewRequestState cb) = mk'view_request_state_cb (\view statptr toggle ->
cb (View view) (fromPrimitive $ WlcViewStateBit statptr) toggle) >>= c'wlc_set_view_request_state_cb
dispatchEvent (ViewRequestMove cb) = mk'view_request_move_cb (\view pointPtr -> do
Just point <- fromPrimitivePtr pointPtr
cb (View view) point) >>= c'wlc_set_view_request_move_cb
dispatchEvent (ViewRequestResize cb) = mk'view_request_resize_cb (\view edge pointPtr -> do
Just point <- fromPrimitivePtr pointPtr
cb (View view) (fromPrimitive $ WlcResizeEdge edge) point) >>= c'wlc_set_view_request_resize_cb
dispatchEvent (ViewRenderPre cb) = mk'view_render_pre_cb (cb . View) >>= c'wlc_set_view_render_pre_cb
dispatchEvent (ViewRenderPost cb) = mk'view_render_post_cb (cb . View) >>= c'wlc_set_view_render_post_cb
dispatchEvent (KeyboardKey cb) = mk'keyboard_key_cb (\view time modifiersPtr key keyState -> do
Just modifier <- fromPrimitivePtr modifiersPtr
let keyst = fromPrimitive $ WlcKeyState keyState
cb (tryGetView view) (convert time) modifier (fromIntegral key) keyst) >>= c'wlc_set_keyboard_key_cb
dispatchEvent (PointerButton cb) = mk'pointer_button_cb (\view time modifiersPtr button buttonState pointPtr -> do
Just point <- fromPrimitivePtr pointPtr
Just modifier <- fromPrimitivePtr modifiersPtr
let buttonst = fromPrimitive $ WlcButtonState buttonState
cb (tryGetView view) (convert time) modifier (convert button) buttonst point) >>= c'wlc_set_pointer_button_cb
dispatchEvent (PointerScroll cb) = mk'pointer_scroll_cb (\view time modifiersPtr axisL ammount -> do
Just modifiers <- fromPrimitivePtr modifiersPtr
let axis = fromPrimitive $ WlcScrollAxisBit axisL
cb (tryGetView view) (convert time) modifiers axis ammount) >>= c'wlc_set_pointer_scroll_cb
dispatchEvent (PointerMotion cb) = mk'pointer_motion_cb (\view time pointPtr -> do
putStrLn $ "dispatchEvent: view=" ++ show view ++ " time=" ++ show time ++ " pointPtr=" ++ show pointPtr
Just point <- fromPrimitivePtr pointPtr
cb (tryGetView view) (convert time) point) >>= c'wlc_set_pointer_motion_cb
dispatchEvent (Touch cb) = mk'touch_cb (\view time modifiersPtr touchType slot pointPtr -> do
Just point <- fromPrimitivePtr pointPtr
Just modifiers <- fromPrimitivePtr modifiersPtr
let tt = fromPrimitive $ WlcTouchType touchType
cb (tryGetView view) (convert time) modifiers tt (convert slot) point) >>= c'wlc_set_touch_cb
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
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 :: IO Bool
initialize = c'wlc_init2
terminate :: IO ()
terminate = c'wlc_terminate
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
getOutputs :: IO [Output]
getOutputs = with (CSize 0) (\cSize -> do
ptr <- c'wlc_get_outputs cSize
size <- peek cSize
handles <- peekArray (convert size) ptr
return $ map Output handles)
getFocusedOutput :: IO Output
getFocusedOutput = Output <$> c'wlc_get_focused_output
outputGetName :: Output -> IO String
outputGetName (Output output) = c'wlc_output_get_name output >>= peekCString
outputGetSleep :: Output -> IO Bool
outputGetSleep (Output output) = c'wlc_output_get_sleep output
outputSetSleep :: Output -> Bool -> IO ()
outputSetSleep (Output output) = c'wlc_output_set_sleep output
outputGetResolution :: Output -> IO Size
outputGetResolution (Output output) = fromMaybe zeroSize <$> (c'wlc_output_get_resolution output >>= fromPrimitivePtr)
outputSetResolution :: Output -> Size -> IO ()
outputSetResolution (Output output) size = with (toPrimitive size) $ c'wlc_output_set_resolution output
outputGetMask :: Output -> IO Word32
outputGetMask (Output output) = convert <$> c'wlc_output_get_mask output
outputSetMask :: Output -> Word32 -> IO ()
outputSetMask (Output output) mask = c'wlc_output_set_mask output (convert mask)
outputGetViews :: Output -> IO [View]
outputGetViews (Output output) = with (CSize 0) (\cSize -> do
ptr <- c'wlc_output_get_views output cSize
size <- peek cSize
handles <- peekArray (convert size) ptr
return $ map View handles)
outputSetViews :: Output -> [View] -> IO Bool
outputSetViews (Output output) views = withArray viewHandles (\cViews ->
c'wlc_output_set_views output cViews viewLength)
where
viewHandles = map getViewHandle views
viewLength = convert $ length views :: CSize
outputFocus :: Output -> IO ()
outputFocus (Output output) = c'wlc_output_focus output
viewFocus :: View -> IO ()
viewFocus (View view) = c'wlc_view_focus view
viewClose :: View -> IO ()
viewClose (View view) = c'wlc_view_close view
viewGetOutput :: View -> IO Output
viewGetOutput (View view) = Output <$> c'wlc_view_get_output view
viewSetOutput :: View -> Output -> IO ()
viewSetOutput (View view) (Output output) = c'wlc_view_set_output view output
viewSendToBack :: View -> IO ()
viewSendToBack (View view) = c'wlc_view_send_to_back view
viewSendBelow :: View -> View -> IO ()
viewSendBelow (View view) (View other) = c'wlc_view_send_below view other
viewBringAbove :: View -> View -> IO ()
viewBringAbove (View view) (View other) = c'wlc_view_bring_above view other
viewBringToFront :: View -> IO ()
viewBringToFront (View view) = c'wlc_view_bring_to_front view
viewGetMask :: View -> IO Word32
viewGetMask (View view) = convert <$> c'wlc_view_get_mask view
viewSetMask :: View -> Word32 -> IO ()
viewSetMask (View view) mask = c'wlc_view_set_mask view (convert mask)
viewGetGeometry :: View -> IO Geometry
viewGetGeometry (View view) = do
geoPtr <- c'wlc_view_get_geometry view
Just geo <- fromPrimitivePtr geoPtr
return geo
viewSetGeometry :: View -> ResizeEdge -> Geometry -> IO ()
viewSetGeometry (View view) resize geom =
with (toPrimitive geom) $ c'wlc_view_set_geometry view (getResizeEdge $ toPrimitive resize)
viewGetViewType :: View -> IO ViewType
viewGetViewType (View view) = fromPrimitive . WlcViewTypeBit <$> c'wlc_view_get_type view
viewSetViewType :: View -> ViewType -> Bool -> IO ()
viewSetViewType (View view) vt = c'wlc_view_set_type view (getViewTypeBit $ toPrimitive vt)
viewGetViewState :: View -> IO ViewState
viewGetViewState (View view) = fromPrimitive . WlcViewStateBit <$> c'wlc_view_get_state view
viewSetViewState :: View -> ViewState -> Bool -> IO ()
viewSetViewState (View view) vs = c'wlc_view_set_state view (getViewStateBit $ toPrimitive vs)
viewGetParent :: View -> IO (Maybe View)
viewGetParent (View view) = tryGetView <$> c'wlc_view_get_parent view
viewSetParent :: View -> View -> IO ()
viewSetParent (View view) (View other) = c'wlc_view_set_parent view other
viewGetTitle :: View -> IO String
viewGetTitle (View view) = c'wlc_view_get_title view >>= peekCString
viewGetClass :: View -> IO String
viewGetClass (View view) = c'wlc_view_get_class view >>= peekCString
viewGetAppId :: View -> IO String
viewGetAppId (View view) = c'wlc_view_get_app_id view >>= peekCString
pointerGetPosition :: IO Point
pointerGetPosition = alloca (\point -> do
c'wlc_pointer_get_position point
Just pt <- fromPrimitivePtr point
return pt)
pointerSetPosition :: Point -> IO ()
pointerSetPosition pt = with point c'wlc_pointer_set_position
where point = toPrimitive pt