----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.WorkspaceByPos
-- Description :  Move new window to non-focused screen based on its requested geometry.
-- Copyright   :  (c) Jan Vornberger 2009
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  jan.vornberger@informatik.uni-oldenburg.de
-- Stability   :  unstable
-- Portability :  not portable
--
-- Useful in a dual-head setup: Looks at the requested geometry of
-- new windows and moves them to the workspace of the non-focused
-- screen if necessary.
--
-----------------------------------------------------------------------------

module XMonad.Hooks.WorkspaceByPos (
    -- * Usage
    -- $usage
    workspaceByPos
    ) where

import XMonad
import XMonad.Prelude
import qualified XMonad.StackSet as W

import Control.Monad.Except (lift, runExceptT, throwError)

-- $usage
-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
--
-- > import XMonad.Hooks.WorkspaceByPos
-- >
-- > myManageHook = workspaceByPos <+> manageHook def
-- >
-- > main = xmonad def { manageHook = myManageHook }

workspaceByPos :: ManageHook
workspaceByPos :: ManageHook
workspaceByPos = (ManageHook
-> (WorkspaceId -> ManageHook) -> Maybe WorkspaceId -> ManageHook
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ManageHook
forall m. Monoid m => m
idHook WorkspaceId -> ManageHook
doShift (Maybe WorkspaceId -> ManageHook)
-> (Window -> Query (Maybe WorkspaceId)) -> Window -> ManageHook
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< X (Maybe WorkspaceId) -> Query (Maybe WorkspaceId)
forall a. X a -> Query a
liftX (X (Maybe WorkspaceId) -> Query (Maybe WorkspaceId))
-> (Window -> X (Maybe WorkspaceId))
-> Window
-> Query (Maybe WorkspaceId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> X (Maybe WorkspaceId)
needsMoving) (Window -> ManageHook) -> Query Window -> ManageHook
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask

needsMoving :: Window -> X (Maybe WorkspaceId)
needsMoving :: Window -> X (Maybe WorkspaceId)
needsMoving Window
w = (Display -> X (Maybe WorkspaceId)) -> X (Maybe WorkspaceId)
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X (Maybe WorkspaceId)) -> X (Maybe WorkspaceId))
-> (Display -> X (Maybe WorkspaceId)) -> X (Maybe WorkspaceId)
forall a b. (a -> b) -> a -> b
$ \Display
d -> do
    -- only relocate windows with non-zero position
    WindowAttributes
wa <- IO WindowAttributes -> X WindowAttributes
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO WindowAttributes -> X WindowAttributes)
-> IO WindowAttributes -> X WindowAttributes
forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO WindowAttributes
getWindowAttributes Display
d Window
w
    (Either WorkspaceId WorkspaceId -> Maybe WorkspaceId)
-> X (Either WorkspaceId WorkspaceId) -> X (Maybe WorkspaceId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe WorkspaceId -> WorkspaceId -> Maybe WorkspaceId
forall a b. a -> b -> a
const Maybe WorkspaceId
forall a. Maybe a
Nothing (WorkspaceId -> Maybe WorkspaceId)
-> (WorkspaceId -> Maybe WorkspaceId)
-> Either WorkspaceId WorkspaceId
-> Maybe WorkspaceId
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
`either` WorkspaceId -> Maybe WorkspaceId
forall a. a -> Maybe a
Just) (X (Either WorkspaceId WorkspaceId) -> X (Maybe WorkspaceId))
-> (ExceptT WorkspaceId X WorkspaceId
    -> X (Either WorkspaceId WorkspaceId))
-> ExceptT WorkspaceId X WorkspaceId
-> X (Maybe WorkspaceId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT WorkspaceId X WorkspaceId
-> X (Either WorkspaceId WorkspaceId)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT WorkspaceId X WorkspaceId -> X (Maybe WorkspaceId))
-> ExceptT WorkspaceId X WorkspaceId -> X (Maybe WorkspaceId)
forall a b. (a -> b) -> a -> b
$ do
        Bool -> ExceptT WorkspaceId X ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ExceptT WorkspaceId X ())
-> Bool -> ExceptT WorkspaceId X ()
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_x WindowAttributes
wa CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0 Bool -> Bool -> Bool
|| WindowAttributes -> CInt
wa_y WindowAttributes
wa CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0
        WindowSet
ws <- (XState -> WindowSet) -> ExceptT WorkspaceId X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
        Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
sc <- X (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> ExceptT
     WorkspaceId
     X
     (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (X (Screen
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
 -> ExceptT
      WorkspaceId
      X
      (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail))
-> X (Screen
        WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> ExceptT
     WorkspaceId
     X
     (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
forall a b. (a -> b) -> a -> b
$ Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> Maybe
     (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
forall a. a -> Maybe a -> a
fromMaybe (WindowSet
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
ws)
                (Maybe
   (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
 -> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> X (Maybe
        (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail))
-> X (Screen
        WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Position
-> Position
-> X (Maybe
        (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail))
pointScreen (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Position) -> CInt -> Position
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_x WindowAttributes
wa) (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Position) -> CInt -> Position
forall a b. (a -> b) -> a -> b
$ WindowAttributes -> CInt
wa_y WindowAttributes
wa)
        Just WorkspaceId
wkspc <- X (Maybe WorkspaceId) -> ExceptT WorkspaceId X (Maybe WorkspaceId)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (X (Maybe WorkspaceId)
 -> ExceptT WorkspaceId X (Maybe WorkspaceId))
-> X (Maybe WorkspaceId)
-> ExceptT WorkspaceId X (Maybe WorkspaceId)
forall a b. (a -> b) -> a -> b
$ ScreenId -> X (Maybe WorkspaceId)
screenWorkspace (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
sc)
        Bool -> ExceptT WorkspaceId X ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ExceptT WorkspaceId X ())
-> Bool -> ExceptT WorkspaceId X ()
forall a b. (a -> b) -> a -> b
$ WindowSet -> WorkspaceId
forall i l a s sd. StackSet i l a s sd -> i
W.currentTag WindowSet
ws WorkspaceId -> WorkspaceId -> Bool
forall a. Eq a => a -> a -> Bool
/= WorkspaceId
wkspc
        WorkspaceId -> ExceptT WorkspaceId X WorkspaceId
forall (m :: * -> *) a. Monad m => a -> m a
return WorkspaceId
wkspc ExceptT WorkspaceId X WorkspaceId
-> ExceptT WorkspaceId X WorkspaceId
-> ExceptT WorkspaceId X WorkspaceId
forall a. a -> a -> a
`asTypeOf` WorkspaceId -> ExceptT WorkspaceId X WorkspaceId
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError WorkspaceId
""