diff options
Diffstat (limited to 'plug/src/Config.hs')
| -rw-r--r-- | plug/src/Config.hs | 93 |
1 files changed, 5 insertions, 88 deletions
diff --git a/plug/src/Config.hs b/plug/src/Config.hs index 7314604..fd337eb 100644 --- a/plug/src/Config.hs +++ b/plug/src/Config.hs @@ -2,17 +2,10 @@ module Config () where import Control.Monad.IO.Class (liftIO) import Data.Bits (shiftL, (.&.)) -import Data.Maybe (fromMaybe) -import Data.Typeable (Typeable) -import Data.Void (Void) import Data.Word (Word32) -import Foreign (Ptr) -import Foreign.C (CDouble) -import Foreign.Marshal.Alloc (alloca) -import Foreign.Ptr (nullPtr) -import Foreign.Storable (peek) -import Montis.Base.Foreign.Runtime import Montis.Core +import Montis.Standard.Drag (DragConfig (DragConfig)) +import Montis.Standard.Mouse (MouseConfig (MouseConfig)) import Montis.Standard.Keys (KeysConfig (KeysConfig), subkeys) foreign export ccall "plugin_cold_start" @@ -45,82 +38,6 @@ mod1Mask = 1 `shiftL` 3 -- WLR_MODIFIER_ALT config :: MontisConfig config = - install (KeysConfig keys) $ - defaultConfig - { startingHooks = - (startingHooks defaultConfig) - { buttonHook = onButton, - motionHook = onMotion - } - } - -data DragState = DragState - { dragToplevel :: Ptr ForeignMontisToplevel, - dragOffsetX :: Double, - dragOffsetY :: Double - } - deriving (Typeable) - -newtype Dragging = Dragging (Maybe DragState) - deriving (Typeable) - -instance StateExtension Dragging where - initialValue = Dragging Nothing - marshalExtension _ = Nothing - demarshalExtension _ = Nothing - -newtype CursorPosition = CursorPosition (Double, Double) - deriving (Typeable) - -instance StateExtension CursorPosition where - initialValue = CursorPosition (0, 0) - marshalExtension _ = Nothing - demarshalExtension _ = Nothing - -leftButton :: Word32 -leftButton = 272 -- BTN_LEFT - -onButton :: ButtonEvent -> Montis () -onButton ev - | buttonEvent_button ev /= leftButton = return () - | buttonEvent_state ev == ButtonPressed = do - self <- getSelfPtr - CursorPosition (x, y) <- xStateGet - newDrag <- liftIO $ do - tl <- foreign_toplevelAt (unwrapSelf self) (realToFrac x) (realToFrac y) - if tl == nullPtr - then return (Dragging Nothing) - else do - (tx, ty) <- getToplevelPosition tl - return $ - Dragging - (Just (DragState tl (x - tx) (y - ty))) - xStatePut newDrag - | buttonEvent_state ev == ButtonReleased = - xStatePut (Dragging Nothing) - | otherwise = return () - -onMotion :: MotionEvent -> Montis () -onMotion ev = do - let (x, y) = motionEvent_absolute ev - xStatePut (CursorPosition (x, y)) - Dragging mdrag <- xStateGet - case mdrag of - Nothing -> return () - Just (DragState tl dx dy) -> do - liftIO $ - foreign_setToplevelPosition - tl - (realToFrac (x - dx)) - (realToFrac (y - dy)) - -unwrapSelf :: SelfPtr -> Ptr Void -unwrapSelf (SelfPtr p) = p - -getToplevelPosition :: Ptr ForeignMontisToplevel -> IO (Double, Double) -getToplevelPosition tl = - alloca $ \xPtr -> alloca $ \yPtr -> do - foreign_getToplevelPosition tl xPtr yPtr - x <- peek xPtr - y <- peek yPtr - return (realToFrac (x :: CDouble), realToFrac (y :: CDouble)) + install MouseConfig $ + install (DragConfig mod1Mask) $ + install (KeysConfig keys) defaultConfig |