{-# LANGUAGE LambdaCase #-}
----------------------------------------------------------------------------
-- |
-- 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 -> (String -> ManageHook) -> Maybe String -> ManageHook
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ManageHook
forall m. Monoid m => m
idHook String -> ManageHook
doShift (Maybe String -> ManageHook)
-> (Window -> Query (Maybe String)) -> Window -> ManageHook
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< X (Maybe String) -> Query (Maybe String)
forall a. X a -> Query a
liftX (X (Maybe String) -> Query (Maybe String))
-> (Window -> X (Maybe String)) -> Window -> Query (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> X (Maybe String)
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 String)
needsMoving Window
w = Window -> X (Maybe WindowAttributes)
safeGetWindowAttributes Window
w X (Maybe WindowAttributes)
-> (Maybe WindowAttributes -> X (Maybe String)) -> X (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe WindowAttributes
Nothing -> Maybe String -> X (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
    Just WindowAttributes
wa -> (Either String String -> Maybe String)
-> X (Either String String) -> X (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Maybe String)
-> (String -> Maybe String) -> Either String String -> Maybe String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe String -> String -> Maybe String
forall a b. a -> b -> a
const Maybe String
forall a. Maybe a
Nothing) String -> Maybe String
forall a. a -> Maybe a
Just) (X (Either String String) -> X (Maybe String))
-> (ExceptT String X String -> X (Either String String))
-> ExceptT String X String
-> X (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT String X String -> X (Either String String)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String X String -> X (Maybe String))
-> ExceptT String X String -> X (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
        -- only relocate windows with non-zero position
        Bool -> ExceptT String X ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ExceptT String X ()) -> Bool -> ExceptT String 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 String X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
        Screen String (Layout Window) Window ScreenId ScreenDetail
sc <- X (Screen String (Layout Window) Window ScreenId ScreenDetail)
-> ExceptT
     String
     X
     (Screen String (Layout Window) Window ScreenId ScreenDetail)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (X (Screen String (Layout Window) Window ScreenId ScreenDetail)
 -> ExceptT
      String
      X
      (Screen String (Layout Window) Window ScreenId ScreenDetail))
-> X (Screen String (Layout Window) Window ScreenId ScreenDetail)
-> ExceptT
     String
     X
     (Screen String (Layout Window) Window ScreenId ScreenDetail)
forall a b. (a -> b) -> a -> b
$ Screen String (Layout Window) Window ScreenId ScreenDetail
-> Maybe
     (Screen String (Layout Window) Window ScreenId ScreenDetail)
-> Screen String (Layout Window) Window ScreenId ScreenDetail
forall a. a -> Maybe a -> a
fromMaybe (WindowSet
-> Screen String (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 String (Layout Window) Window ScreenId ScreenDetail)
 -> Screen String (Layout Window) Window ScreenId ScreenDetail)
-> X (Maybe
        (Screen String (Layout Window) Window ScreenId ScreenDetail))
-> X (Screen String (Layout Window) Window ScreenId ScreenDetail)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Position
-> Position
-> X (Maybe
        (Screen String (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 String
wkspc <- X (Maybe String) -> ExceptT String X (Maybe String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (X (Maybe String) -> ExceptT String X (Maybe String))
-> X (Maybe String) -> ExceptT String X (Maybe String)
forall a b. (a -> b) -> a -> b
$ ScreenId -> X (Maybe String)
screenWorkspace (Screen String (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen Screen String (Layout Window) Window ScreenId ScreenDetail
sc)
        Bool -> ExceptT String X ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> ExceptT String X ()) -> Bool -> ExceptT String X ()
forall a b. (a -> b) -> a -> b
$ WindowSet -> String
forall i l a s sd. StackSet i l a s sd -> i
W.currentTag WindowSet
ws String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
wkspc
        String -> ExceptT String X String
forall (m :: * -> *) a. Monad m => a -> m a
return String
wkspc ExceptT String X String
-> ExceptT String X String -> ExceptT String X String
forall a. a -> a -> a
`asTypeOf` String -> ExceptT String X String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
""