path: root/src/Rahm/Desktop/Dragging.hs

module Rahm.Desktop.Dragging where

import Control.Arrow ((&&&))
import qualified Control.Exception as C
import Control.Monad (filterM, forM_, when)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Maybe (MaybeT (MaybeT))
import qualified Data.Foldable as Foldable
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe, isJust, mapMaybe)
import qualified Data.Set as Set
import Graphics.X11.Xlib.Extras
import Rahm.Desktop.BorderColors (BorderColor (BorderColor), setBorderColor)
import Rahm.Desktop.Common (floatAll, pointerLocation, pointerWindow, runMaybeT_)
import Rahm.Desktop.Layout.Hole (addHoleForWindow, removeHoleForWindow, resetHole)
import Rahm.Desktop.Layout.PinWindow (isWindowPinned, pinWindow, unpinWindow)
import Rahm.Desktop.Logger
import Rahm.Desktop.Marking (setAlternateWindows)
import qualified Rahm.Desktop.StackSet as W
import XMonad (X, io)
import qualified XMonad as X
import XMonad.Util.WindowProperties (getProp32s)
import Rahm.Desktop.Workspaces (accompanyingWorkspace)

-- Action which happens after a dragging event.
--
-- The window is the window under
newtype AfterDragAction = AfterDragAction (X.Window -> X.Button -> X ())

instance Semigroup AfterDragAction where
  (AfterDragAction f1) <> (AfterDragAction f2) =
    AfterDragAction $ \w b -> f1 w b >> f2 w b

instance Monoid AfterDragAction where
  mappend = (<>)
  mempty = AfterDragAction $ \_ _ -> return ()

dragBorderColor = BorderColor "#00ffff" "#80a0a0"

afterDrag :: X () -> X ()
afterDrag action = do
  X.modify $ \case
    st@(X.XState {X.dragging = Just (fn, cleanup)}) ->
      st {X.dragging = Just (fn, cleanup >> action)}
    s -> s

isDragging :: X Bool
isDragging = X.gets (isJust . X.dragging)

finishDrag :: X ()
finishDrag = runMaybeT_ $ do
  (_, cleanup) <- MaybeT $ X.gets X.dragging
  X.modify $ \s -> s {X.dragging = Nothing}
  lift cleanup

windowsUnderCursor :: X [X.Window]
windowsUnderCursor = do
  (dpy, root) <- X.asks $ (,) <$> X.display <*> X.theRoot
  aw <- X.withWindowSet (return . W.allVisibleWindows)
  let fi :: (Integral a, Integral b) => a -> b
      fi = fromIntegral
  (cx, cy) <- pointerLocation

  filterM
    ( \win -> do
        (_, fi -> x, fi -> y, fi -> w, fi -> h, _, _) <- io $ X.getGeometry dpy win
        return
          ( cx > x
              && cx < x + fi w
              && cy > y
              && cy < y + h
          )
    )
    aw

sinkOnRelease :: AfterDragAction
sinkOnRelease = AfterDragAction $ \window _ -> sinkByWindowUnderCursor window

sinkByWindowUnderCursor :: X.Window -> X ()
sinkByWindowUnderCursor window = do
  unpinWindow window

  (cx, cy) <- pointerLocation
  wins <- filter (/= window) <$> windowsUnderCursor
  t <- fmap (W.tag . W.workspace) <$> X.pointScreen cx cy

  X.windows $
    W.focusWindow window
      . case wins of
        (h : _) -> W.sinkBy window h
        _ -> W.sink window
      . ( \ss -> case t of
            Nothing -> ss
            Just t' -> W.shiftWin t' window ss
        )
  where
    fi = fromIntegral

ifReleased :: X.Button -> AfterDragAction -> AfterDragAction
ifReleased but (AfterDragAction act) = AfterDragAction $ \win b -> do
  when (but == b) $ act win b

-- Like ifReleased, but with a function instead of an AfterDragAction
ifReleased' :: X.Button -> (X.Window -> X.Button -> X ()) -> AfterDragAction
ifReleased' but act = ifReleased but (AfterDragAction act)

mouseResizeWindowAndThen ::
  (X.Window -> X ()) ->
  AfterDragAction ->
  X.Window ->
  X ()
mouseResizeWindowAndThen beforeAction (AfterDragAction releaseAction) window = do
  beforeAction window
  windowPinned <- isWindowPinned window
  unpinWindow window
  tilePosition <- X.withWindowSet $ return . W.windowTilePosition window
  mapM_ (X.broadcastMessage . flip addHoleForWindow window) tilePosition

  X.mouseResizeWindow window

  afterDrag $ do
    X.broadcastMessage $ removeHoleForWindow window
    curev <- X.asks X.currentEvent
    when windowPinned $
      pinWindow window
    releaseAction
      window
      ( maybe
          0
          ( \case
              X.ButtonEvent {X.ev_button = b} -> b
              _ -> 0
          )
          curev
      )
    X.refresh

mouseMoveWindowsAndThen ::
  (Foldable f) =>
  (f X.Window -> X ()) ->
  AfterDragAction ->
  f X.Window ->
  X ()
mouseMoveWindowsAndThen beforeAction (AfterDragAction releaseAction) windowsF = do
  let windows = Foldable.toList windowsF

  beforeAction windowsF

  pinnedWindows <- Set.fromList <$> filterM isWindowPinned windows
  mapM_ unpinWindow windows

  tilePositions <- X.withWindowSet $
    \ws -> return $ mapMaybe (\win -> (win,) <$> W.windowTilePosition win ws) windows

  mapM_
    ( \(win, pos) ->
        X.broadcastMessage $ addHoleForWindow pos win
    )
    tilePositions

  case windows of
    [win] -> X.mouseMoveWindow win
    _ -> X.withDisplay $ \d -> do
      floatAll windows
      was <-
        io $
          mapM
            ( \w -> C.handle (\(C.SomeException _) -> return Nothing) $ do
                wa <- X.getWindowAttributes d w
                (_, _, _, fi -> ox, fi -> oy, _, _, _) <- io $ X.queryPointer d w
                return (Just (w, wa, ox, oy))
            )
            windows
      X.mouseDrag
        ( \ex ey -> do
            forM_ was $ \case
              Just (w, wa, ox, oy) -> do
                io $
                  X.moveWindow
                    d
                    w
                    (fromIntegral (fromIntegral (wa_x wa) + (ex - ox)))
                    (fromIntegral (fromIntegral (wa_y wa) + (ey - oy)))
              Nothing -> return ()
        )
        (floatAll windows)

  afterDrag $ do
    mapM_ pinWindow pinnedWindows
    curev <- X.asks X.currentEvent

    forM_ windows $ \window -> do
      X.broadcastMessage $ removeHoleForWindow window

      releaseAction
        window
        ( maybe
            0
            ( \case
                X.ButtonEvent {X.ev_button = b} -> b
                _ -> 0
            )
            curev
        )

    X.refresh
  where
    fi = fromIntegral

dragWorkspace :: X ()
dragWorkspace = do
  (ox, oy) <- pointerLocation
  X.mouseDrag (\_ _ -> return ()) $ do
    (nx, ny) <- pointerLocation
    runMaybeT_ $ do
      (W.Screen (W.tag -> ws1) _ _) <- MaybeT $ X.pointScreen ox oy
      (W.Screen (W.tag -> ws2) _ _) <- MaybeT $ X.pointScreen nx ny

      lift $ X.windows $ W.switchWorkspaces ws1 ws2

dragAlternateWorkspace :: X ()
dragAlternateWorkspace = do
  (ox, oy) <- pointerLocation
  X.mouseDrag (\_ _ -> return ()) $ do
    (nx, ny) <- pointerLocation
    runMaybeT_ $ do
      (W.Screen (W.tag -> ws1) _ _) <- MaybeT $ X.pointScreen ox oy
      (W.Screen (W.tag -> ws2) _ _) <- MaybeT $ X.pointScreen nx ny

      lift $ X.windows $ W.switchWorkspaces (accompanyingWorkspace ws1) ws2

dragWindow :: X ()
dragWindow = do
  w <- pointerWindow
  isDockOrRoot <- windowIsDockOrRoot w
  if isDockOrRoot
    then dragWorkspace
    else do
      cleanup <- setBorderColor dragBorderColor [w]

      ref <- io $ newIORef (w, return ())

      X.mouseDrag
        ( \_ _ -> do
            w' <- pointerWindow
            (ow, ocleanup) <- io $ readIORef ref
            case () of
              () | ow /= w' -> do
                ocleanup
                cleanup' <-
                  if w' == 0 || w' == w
                    then return (return ())
                    else setBorderColor dragBorderColor [w']
                io $ writeIORef ref (w', cleanup')
              () -> return ()

            return ()
        )
        $ do
          (nx, ny) <- pointerLocation
          w' <- pointerWindow
          (_, iocleanup) <- io $ readIORef ref
          isDockOrRoot <- windowIsDockOrRoot w'
          if isDockOrRoot
            then runMaybeT_ $ do
              (W.Screen (W.tag -> ws1) _ _) <- MaybeT $ X.pointScreen nx ny
              lift $ do
                setAlternateWindows [w]
                X.windows $ W.sink w . W.shiftWin ws1 w
            else do
              X.windows $ W.focusWindow w . W.swapWindows [(w, w')]

              setAlternateWindows [w, w']

              iocleanup
              cleanup
  where
    windowIsDockOrRoot 0 = return True
    windowIsDockOrRoot w = do
      dock <- X.getAtom "_NET_WM_WINDOW_TYPE_DOCK"
      desk <- X.getAtom "_NET_WM_WINDOW_TYPE_DESKTOP"
      mbr <-
        if w == 0
          then return Nothing
          else getProp32s "_NET_WM_WINDOW_TYPE" w

      return $ maybe False (any ((`elem` [dock, desk]) . fromIntegral)) mbr