[reorg] remove references to foreign_* outside the core.

Added Monadic counterparts that work better.

6 files changed, 138 insertions, 105 deletions

diff --git a/plug/src/Config.hs b/plug/src/Config.hs
index c76898e..50133b4 100644
--- a/plug/src/Config.hs
+++ b/plug/src/Config.hs
@@ -4,8 +4,8 @@ import Control.Monad.IO.Class (liftIO)
 import Data.Bits (shiftL, (.&.))
 import Data.Word (Word32)
 import Montis.Core
-import Montis.Base.Foreign.Runtime
-import Montis.Standard.Drag (DragConfig (DragConfig), unwrapSelf)
+import Montis.Core.Runtime (warpCursor)
+import Montis.Standard.Drag (DragConfig (DragConfig))
 import Montis.Standard.Keys (KeysConfig (KeysConfig), subkeys)
 import Montis.Standard.Mouse (MouseConfig (MouseConfig))
 
@@ -30,8 +30,7 @@ keys ev
         subkeys $ \ev -> case keyEvent_codepoint ev of
           'k' -> do
             liftIO (putStrLn "k was pressed after j!")
-            self <- getSelfPtr
-            liftIO $ foreign_warpCursor (unwrapSelf self) 0 0
+            warpCursor 0 0
             return True
           _ -> return False
       _ -> return False
diff --git a/plug/src/Montis/Core.hs b/plug/src/Montis/Core.hs
index 65dcdad..5399f1e 100644
--- a/plug/src/Montis/Core.hs
+++ b/plug/src/Montis/Core.hs
@@ -5,5 +5,6 @@ where
 
 import Montis.Core.Events as X
 import Montis.Core.Monad as X
+import Montis.Core.Runtime as X
 import Montis.Core.Start as X
 import Montis.Core.State as X
diff --git a/plug/src/Montis/Core/Runtime.hs b/plug/src/Montis/Core/Runtime.hs
new file mode 100644
index 0000000..0d4c905
--- /dev/null
+++ b/plug/src/Montis/Core/Runtime.hs
@@ -0,0 +1,82 @@
+module Montis.Core.Runtime
+  ( ToplevelHandle,
+    focusToplevel,
+    getSeat,
+    getToplevelGeometry,
+    setToplevelGeometry,
+    setToplevelPosition,
+    toplevelAt,
+    warpCursor,
+  )
+where
+
+import Control.Monad.IO.Class (liftIO)
+import Data.Void (Void)
+import Foreign (Ptr)
+import Foreign.C (CDouble (..))
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.Ptr (castPtr, nullPtr)
+import Foreign.Storable (peek)
+import Montis.Base.Foreign.Runtime
+import Montis.Base.Foreign.WlRoots.Types (ForeignWlrSeat, WlrSeat (WlrSeat))
+import Montis.Core.Monad (Montis, getSelfPtr)
+import Montis.Core.State (SelfPtr (..))
+
+type ToplevelHandle = Ptr ForeignMontisToplevel
+
+unwrapSelf :: SelfPtr -> Ptr Void
+unwrapSelf (SelfPtr p) = p
+
+getSeat :: Montis (Maybe WlrSeat)
+getSeat = do
+  self <- getSelfPtr
+  seatPtr <- liftIO $ foreign_getSeat (unwrapSelf self)
+  if seatPtr == nullPtr
+    then return Nothing
+    else return $ Just (WlrSeat (castPtr seatPtr :: Ptr ForeignWlrSeat))
+
+toplevelAt :: Double -> Double -> Montis (Maybe ToplevelHandle)
+toplevelAt lx ly = do
+  self <- getSelfPtr
+  tl <- liftIO $ foreign_toplevelAt (unwrapSelf self) (realToFrac lx) (realToFrac ly)
+  if tl == nullPtr
+    then return Nothing
+    else return (Just tl)
+
+getToplevelGeometry :: ToplevelHandle -> Montis (Double, Double, Double, Double)
+getToplevelGeometry tl =
+  liftIO $
+    alloca $ \xPtr -> alloca $ \yPtr -> alloca $ \wPtr -> alloca $ \hPtr -> do
+      foreign_getToplevelGeometry tl xPtr yPtr wPtr hPtr
+      x <- peek xPtr
+      y <- peek yPtr
+      w <- peek wPtr
+      h <- peek hPtr
+      return
+        ( realToFrac (x :: CDouble),
+          realToFrac (y :: CDouble),
+          realToFrac (w :: CDouble),
+          realToFrac (h :: CDouble)
+        )
+
+setToplevelGeometry :: ToplevelHandle -> Double -> Double -> Double -> Double -> Montis ()
+setToplevelGeometry tl x y w h =
+  liftIO $
+    foreign_setToplevelGeometry
+      tl
+      (realToFrac x)
+      (realToFrac y)
+      (realToFrac w)
+      (realToFrac h)
+
+setToplevelPosition :: ToplevelHandle -> Double -> Double -> Montis ()
+setToplevelPosition tl x y =
+  liftIO $ foreign_setToplevelPosition tl (realToFrac x) (realToFrac y)
+
+focusToplevel :: ToplevelHandle -> Montis ()
+focusToplevel tl = liftIO $ foreign_focusToplevel tl
+
+warpCursor :: Double -> Double -> Montis ()
+warpCursor lx ly = do
+  self <- getSelfPtr
+  liftIO $ foreign_warpCursor (unwrapSelf self) (realToFrac lx) (realToFrac ly)
diff --git a/plug/src/Montis/Standard/Drag.hs b/plug/src/Montis/Standard/Drag.hs
index 720398d..a6ee878 100644
--- a/plug/src/Montis/Standard/Drag.hs
+++ b/plug/src/Montis/Standard/Drag.hs
@@ -1,17 +1,10 @@
 module Montis.Standard.Drag where
 
-import Control.Monad.IO.Class (liftIO)
 import Data.Bits ((.&.))
 import Data.Data (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.Core.Runtime
 import Montis.Core.State
   ( Config (startingHooks),
     ConfigModule (..),
@@ -40,14 +33,14 @@ instance ConfigModule Montis DragConfig where
           }
 
 data DragState = DragState
-  { dragToplevel :: Ptr ForeignMontisToplevel,
+  { dragToplevel :: ToplevelHandle,
     dragOffsetX :: Double,
     dragOffsetY :: Double
   }
   deriving (Typeable)
 
 data ResizeState = ResizeState
-  { resizeToplevel :: Ptr ForeignMontisToplevel,
+  { resizeToplevel :: ToplevelHandle,
     resizeStartX :: Double,
     resizeStartY :: Double,
     resizeStartW :: Double,
@@ -83,36 +76,29 @@ onButton modMask ev
       if buttonEvent_modifiers ev .&. modMask == 0
         then return ()
         else do
-          self <- getSelfPtr
           CursorPosition (x, y) <- xStateGet
-          (newDrag, warpState) <- liftIO $ do
-            tl <- foreign_toplevelAt (unwrapSelf self) (realToFrac x) (realToFrac y)
-            if tl == nullPtr
-              then return (Dragging Nothing, Nothing)
-              else do
-                (tx, ty, tw, th) <- getToplevelGeometry tl
-                if buttonEvent_button ev == rightButton
-                  then do
-                    let warpX = tx + tw
-                        warpY = ty + th
-                    foreign_warpCursor (unwrapSelf self) (realToFrac warpX) (realToFrac warpY)
-                    return
-                      ( Dragging
-                          ( Just
-                              ( DragResize
-                                  (ResizeState tl tx ty tw th warpX warpY)
-                              )
-                          ),
-                        Just (CursorPosition (warpX, warpY))
+          mtl <- toplevelAt x y
+          case mtl of
+            Nothing -> xStatePut (Dragging Nothing)
+            Just tl -> do
+              (tx, ty, tw, th) <- getToplevelGeometry tl
+              if buttonEvent_button ev == rightButton
+                then do
+                  let warpX = tx + tw
+                      warpY = ty + th
+                  warpCursor warpX warpY
+                  xStatePut (CursorPosition (warpX, warpY))
+                  xStatePut $
+                    Dragging
+                      ( Just
+                          ( DragResize
+                              (ResizeState tl tx ty tw th warpX warpY)
+                          )
                       )
-                  else
-                    return
-                      ( Dragging
-                          (Just (DragMove (DragState tl (x - tx) (y - ty)))),
-                        Nothing
-                      )
-          mapM_ xStatePut warpState
-          xStatePut newDrag
+                else
+                  xStatePut $
+                    Dragging
+                      (Just (DragMove (DragState tl (x - tx) (y - ty))))
   | buttonEvent_state ev == ButtonReleased =
       xStatePut (Dragging Nothing)
   | otherwise = return ()
@@ -124,37 +110,14 @@ onMotion ev = do
   Dragging mdrag <- xStateGet
   case mdrag of
     Nothing -> return ()
-    Just (DragMove (DragState tl dx dy)) -> do
-      liftIO $
-        foreign_setToplevelPosition
-          tl
-          (realToFrac (x - dx))
-          (realToFrac (y - dy))
+    Just (DragMove (DragState tl dx dy)) ->
+      setToplevelPosition tl (x - dx) (y - dy)
     Just (DragResize rs) -> do
       let newW = max 1 (resizeStartW rs + (x - resizeStartCursorX rs))
           newH = max 1 (resizeStartH rs + (y - resizeStartCursorY rs))
-      liftIO $
-        foreign_setToplevelGeometry
-          (resizeToplevel rs)
-          (realToFrac (resizeStartX rs))
-          (realToFrac (resizeStartY rs))
-          (realToFrac newW)
-          (realToFrac newH)
-
-unwrapSelf :: SelfPtr -> Ptr Void
-unwrapSelf (SelfPtr p) = p
-
-getToplevelGeometry :: Ptr ForeignMontisToplevel -> IO (Double, Double, Double, Double)
-getToplevelGeometry tl =
-  alloca $ \xPtr -> alloca $ \yPtr -> alloca $ \wPtr -> alloca $ \hPtr -> do
-    foreign_getToplevelGeometry tl xPtr yPtr wPtr hPtr
-    x <- peek xPtr
-    y <- peek yPtr
-    w <- peek wPtr
-    h <- peek hPtr
-    return
-      ( realToFrac (x :: CDouble),
-        realToFrac (y :: CDouble),
-        realToFrac (w :: CDouble),
-        realToFrac (h :: CDouble)
-      )
+      setToplevelGeometry
+        (resizeToplevel rs)
+        (resizeStartX rs)
+        (resizeStartY rs)
+        newW
+        newH
diff --git a/plug/src/Montis/Standard/Keys.hs b/plug/src/Montis/Standard/Keys.hs
index 24f232b..0b670eb 100644
--- a/plug/src/Montis/Standard/Keys.hs
+++ b/plug/src/Montis/Standard/Keys.hs
@@ -6,17 +6,14 @@ import Data.Data (Typeable)
 import Data.Default.Class (Default (..))
 import Data.Set qualified as Set
 import Data.Word (Word32)
-import Foreign.Ptr (Ptr, castPtr, nullPtr)
-import Montis.Base.Foreign.Runtime (foreign_getSeat)
 import Montis.Base.Foreign.WlRoots (seatKeyboardNotifyKey)
-import Montis.Base.Foreign.WlRoots.Types (ForeignWlrSeat, WlrSeat (WlrSeat))
 import Montis.Core.Events (KeyEvent (..), KeyState (..))
-import Montis.Core.Monad (Montis, getSelfPtr, xConfigGet, xStateGet, xStateModify)
+import Montis.Core.Monad (Montis, xConfigGet, xStateGet, xStateModify)
+import Montis.Core.Runtime (getSeat)
 import Montis.Core.State
   ( Config (startingHooks),
     ConfigModule (..),
     Hooks (keyHook),
-    SelfPtr (..),
     StateExtension (..),
   )
 
@@ -86,9 +83,7 @@ instance ConfigModule Montis KeysConfig where
                 else return False
 
             if not handled
-              then do
-                self <- getSelfPtr
-                liftIO $ forwardKeyToSeat self ev
+              then forwardKeyToSeat ev
               else when (isKeyPress ev) $
                 xStateModify $
                   \ks ->
@@ -97,17 +92,18 @@ instance ConfigModule Montis KeysConfig where
                           Set.insert (keyEvent_keycode ev) (ignoredKeys ks)
                       }
 
-forwardKeyToSeat :: SelfPtr -> KeyEvent -> IO ()
-forwardKeyToSeat (SelfPtr ctx) ev = do
-  seatPtr <- foreign_getSeat ctx
-  if seatPtr == nullPtr
-    then return ()
-    else
-      seatKeyboardNotifyKey
-        (WlrSeat (castPtr seatPtr :: Ptr ForeignWlrSeat))
-        (keyEvent_timeMs ev)
-        (keyEvent_keycode ev)
-        (keyStateToWord32 (keyEvent_state ev))
+forwardKeyToSeat :: KeyEvent -> Montis ()
+forwardKeyToSeat ev = do
+  mseat <- getSeat
+  case mseat of
+    Nothing -> return ()
+    Just seat ->
+      liftIO $
+        seatKeyboardNotifyKey
+          seat
+          (keyEvent_timeMs ev)
+          (keyEvent_keycode ev)
+          (keyStateToWord32 (keyEvent_state ev))
 
 keyStateToWord32 :: KeyState -> Word32
 keyStateToWord32 KeyReleased = 0
diff --git a/plug/src/Montis/Standard/Mouse.hs b/plug/src/Montis/Standard/Mouse.hs
index b671206..933a2f4 100644
--- a/plug/src/Montis/Standard/Mouse.hs
+++ b/plug/src/Montis/Standard/Mouse.hs
@@ -1,11 +1,8 @@
 module Montis.Standard.Mouse where
 
-import Control.Monad.IO.Class (liftIO)
 import Data.Data (Typeable)
-import Data.Void (Void)
-import Foreign.Ptr (Ptr, nullPtr)
-import Montis.Base.Foreign.Runtime (foreign_focusToplevel, foreign_toplevelAt)
 import Montis.Core
+import Montis.Core.Runtime (focusToplevel, toplevelAt)
 import Montis.Core.State
   ( Config (startingHooks),
     ConfigModule (..),
@@ -46,13 +43,8 @@ onButton :: ButtonEvent -> Montis ()
 onButton ev
   | buttonEvent_state ev /= ButtonPressed = return ()
   | otherwise = do
-      self <- getSelfPtr
       CursorPosition (x, y) <- xStateGet
-      liftIO $ do
-        tl <- foreign_toplevelAt (unwrapSelf self) (realToFrac x) (realToFrac y)
-        if tl == nullPtr
-          then return ()
-          else foreign_focusToplevel tl
-
-unwrapSelf :: SelfPtr -> Ptr Void
-unwrapSelf (SelfPtr p) = p
+      mtl <- toplevelAt x y
+      case mtl of
+        Nothing -> return ()
+        Just tl -> focusToplevel tl