-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.ManageHook
-- Copyright   :  (c) Spencer Janssen 2007
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  spencerjanssen@gmail.com
-- Stability   :  unstable
--
-- An EDSL for ManageHooks
--
-----------------------------------------------------------------------------

-- XXX examples required

module XMonad.ManageHook where

import XMonad.Core
import Graphics.X11.Xlib.Extras
import Graphics.X11.Xlib (Display, Window, internAtom, wM_NAME)
import Control.Exception (bracket, SomeException(..))
import qualified Control.Exception as E
import Control.Monad.Reader
import Data.Maybe
import Data.Monoid
import qualified XMonad.StackSet as W
import XMonad.Operations (floatLocation, reveal, isFixedSizeOrTransient)

-- | Lift an 'X' action to a 'Query'.
liftX :: X a -> Query a
liftX :: forall a. X a -> Query a
liftX = ReaderT Window X a -> Query a
forall a. ReaderT Window X a -> Query a
Query (ReaderT Window X a -> Query a)
-> (X a -> ReaderT Window X a) -> X a -> Query a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. X a -> ReaderT Window X a
forall (m :: * -> *) a. Monad m => m a -> ReaderT Window m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | The identity hook that returns the WindowSet unchanged.
idHook :: Monoid m => m
idHook :: forall m. Monoid m => m
idHook = m
forall m. Monoid m => m
mempty

-- | Infix 'mappend'. Compose two 'ManageHook' from right to left.
(<+>) :: Monoid m => m -> m -> m
<+> :: forall m. Monoid m => m -> m -> m
(<+>) = m -> m -> m
forall m. Monoid m => m -> m -> m
mappend

-- | Compose the list of 'ManageHook's.
composeAll :: Monoid m => [m] -> m
composeAll :: forall m. Monoid m => [m] -> m
composeAll = [m] -> m
forall m. Monoid m => [m] -> m
mconcat

infix 0 -->

-- | @p --> x@.  If @p@ returns 'True', execute the 'ManageHook'.
--
-- > (-->) :: Monoid m => Query Bool -> Query m -> Query m -- a simpler type
(-->) :: (Monad m, Monoid a) => m Bool -> m a -> m a
m Bool
p --> :: forall (m :: * -> *) a. (Monad m, Monoid a) => m Bool -> m a -> m a
--> m a
f = m Bool
p m Bool -> (Bool -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> if Bool
b then m a
f else a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall m. Monoid m => m
mempty

-- | @q =? x@. if the result of @q@ equals @x@, return 'True'.
(=?) :: Eq a => Query a -> a -> Query Bool
Query a
q =? :: forall a. Eq a => Query a -> a -> Query Bool
=? a
x = (a -> Bool) -> Query a -> Query Bool
forall a b. (a -> b) -> Query a -> Query b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x) Query a
q

infixr 3 <&&>, <||>

-- | '&&' lifted to a 'Monad'.
(<&&>) :: Monad m => m Bool -> m Bool -> m Bool
m Bool
x <&&> :: forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<&&> m Bool
y = m Bool -> m Bool -> m Bool -> m Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
x m Bool
y (Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)

-- | '||' lifted to a 'Monad'.
(<||>) :: Monad m => m Bool -> m Bool -> m Bool
m Bool
x <||> :: forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<||> m Bool
y = m Bool -> m Bool -> m Bool -> m Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
x (Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) m Bool
y

-- | Return the window title.
title :: Query String
title :: Query WorkspaceId
title = Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask Query Window -> (Window -> Query WorkspaceId) -> Query WorkspaceId
forall a b. Query a -> (a -> Query b) -> Query b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Window
w -> X WorkspaceId -> Query WorkspaceId
forall a. X a -> Query a
liftX (X WorkspaceId -> Query WorkspaceId)
-> X WorkspaceId -> Query WorkspaceId
forall a b. (a -> b) -> a -> b
$ do
    Display
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
    let
        getProp :: IO TextProperty
getProp =
            (Display -> WorkspaceId -> Bool -> IO Window
internAtom Display
d WorkspaceId
"_NET_WM_NAME" Bool
False IO Window -> (Window -> IO TextProperty) -> IO TextProperty
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Display -> Window -> Window -> IO TextProperty
getTextProperty Display
d Window
w)
                IO TextProperty
-> (SomeException -> IO TextProperty) -> IO TextProperty
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException e
_) -> Display -> Window -> Window -> IO TextProperty
getTextProperty Display
d Window
w Window
wM_NAME
        extract :: TextProperty -> IO WorkspaceId
extract TextProperty
prop = do [WorkspaceId]
l <- Display -> TextProperty -> IO [WorkspaceId]
wcTextPropertyToTextList Display
d TextProperty
prop
                          WorkspaceId -> IO WorkspaceId
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (WorkspaceId -> IO WorkspaceId) -> WorkspaceId -> IO WorkspaceId
forall a b. (a -> b) -> a -> b
$ WorkspaceId -> Maybe WorkspaceId -> WorkspaceId
forall a. a -> Maybe a -> a
fromMaybe WorkspaceId
"" (Maybe WorkspaceId -> WorkspaceId)
-> Maybe WorkspaceId -> WorkspaceId
forall a b. (a -> b) -> a -> b
$ [WorkspaceId] -> Maybe WorkspaceId
forall a. [a] -> Maybe a
listToMaybe [WorkspaceId]
l
    IO WorkspaceId -> X WorkspaceId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO WorkspaceId -> X WorkspaceId)
-> IO WorkspaceId -> X WorkspaceId
forall a b. (a -> b) -> a -> b
$ IO TextProperty
-> (TextProperty -> IO CInt)
-> (TextProperty -> IO WorkspaceId)
-> IO WorkspaceId
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO TextProperty
getProp (Ptr CChar -> IO CInt
forall a. Ptr a -> IO CInt
xFree (Ptr CChar -> IO CInt)
-> (TextProperty -> Ptr CChar) -> TextProperty -> IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextProperty -> Ptr CChar
tp_value) TextProperty -> IO WorkspaceId
extract IO WorkspaceId
-> (SomeException -> IO WorkspaceId) -> IO WorkspaceId
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException e
_) -> WorkspaceId -> IO WorkspaceId
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return WorkspaceId
""

-- | Return the application name; i.e., the /first/ string returned by
-- @WM_CLASS@.
appName :: Query String
appName :: Query WorkspaceId
appName = Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask Query Window -> (Window -> Query WorkspaceId) -> Query WorkspaceId
forall a b. Query a -> (a -> Query b) -> Query b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Window
w -> X WorkspaceId -> Query WorkspaceId
forall a. X a -> Query a
liftX (X WorkspaceId -> Query WorkspaceId)
-> X WorkspaceId -> Query WorkspaceId
forall a b. (a -> b) -> a -> b
$ (Display -> X WorkspaceId) -> X WorkspaceId
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X WorkspaceId) -> X WorkspaceId)
-> (Display -> X WorkspaceId) -> X WorkspaceId
forall a b. (a -> b) -> a -> b
$ \Display
d -> (ClassHint -> WorkspaceId) -> X ClassHint -> X WorkspaceId
forall a b. (a -> b) -> X a -> X b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ClassHint -> WorkspaceId
resName (X ClassHint -> X WorkspaceId) -> X ClassHint -> X WorkspaceId
forall a b. (a -> b) -> a -> b
$ IO ClassHint -> X ClassHint
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO ClassHint -> X ClassHint) -> IO ClassHint -> X ClassHint
forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO ClassHint
getClassHint Display
d Window
w)

-- | Backwards compatible alias for 'appName'.
resource :: Query String
resource :: Query WorkspaceId
resource = Query WorkspaceId
appName

-- | Return the resource class; i.e., the /second/ string returned by
-- @WM_CLASS@.
className :: Query String
className :: Query WorkspaceId
className = Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask Query Window -> (Window -> Query WorkspaceId) -> Query WorkspaceId
forall a b. Query a -> (a -> Query b) -> Query b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Window
w -> X WorkspaceId -> Query WorkspaceId
forall a. X a -> Query a
liftX (X WorkspaceId -> Query WorkspaceId)
-> X WorkspaceId -> Query WorkspaceId
forall a b. (a -> b) -> a -> b
$ (Display -> X WorkspaceId) -> X WorkspaceId
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X WorkspaceId) -> X WorkspaceId)
-> (Display -> X WorkspaceId) -> X WorkspaceId
forall a b. (a -> b) -> a -> b
$ \Display
d -> (ClassHint -> WorkspaceId) -> X ClassHint -> X WorkspaceId
forall a b. (a -> b) -> X a -> X b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ClassHint -> WorkspaceId
resClass (X ClassHint -> X WorkspaceId) -> X ClassHint -> X WorkspaceId
forall a b. (a -> b) -> a -> b
$ IO ClassHint -> X ClassHint
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO ClassHint -> X ClassHint) -> IO ClassHint -> X ClassHint
forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO ClassHint
getClassHint Display
d Window
w)

-- | A query that can return an arbitrary X property of type 'String',
--   identified by name.
stringProperty :: String -> Query String
stringProperty :: WorkspaceId -> Query WorkspaceId
stringProperty WorkspaceId
p = Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask Query Window -> (Window -> Query WorkspaceId) -> Query WorkspaceId
forall a b. Query a -> (a -> Query b) -> Query b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Window
w -> X WorkspaceId -> Query WorkspaceId
forall a. X a -> Query a
liftX (X WorkspaceId -> Query WorkspaceId)
-> X WorkspaceId -> Query WorkspaceId
forall a b. (a -> b) -> a -> b
$ (Display -> X WorkspaceId) -> X WorkspaceId
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X WorkspaceId) -> X WorkspaceId)
-> (Display -> X WorkspaceId) -> X WorkspaceId
forall a b. (a -> b) -> a -> b
$ \Display
d -> WorkspaceId -> Maybe WorkspaceId -> WorkspaceId
forall a. a -> Maybe a -> a
fromMaybe WorkspaceId
"" (Maybe WorkspaceId -> WorkspaceId)
-> X (Maybe WorkspaceId) -> X WorkspaceId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> Window -> WorkspaceId -> X (Maybe WorkspaceId)
getStringProperty Display
d Window
w WorkspaceId
p)

getStringProperty :: Display -> Window -> String -> X (Maybe String)
getStringProperty :: Display -> Window -> WorkspaceId -> X (Maybe WorkspaceId)
getStringProperty Display
d Window
w WorkspaceId
p = do
  Window
a  <- WorkspaceId -> X Window
getAtom WorkspaceId
p
  Maybe [CChar]
md <- IO (Maybe [CChar]) -> X (Maybe [CChar])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe [CChar]) -> X (Maybe [CChar]))
-> IO (Maybe [CChar]) -> X (Maybe [CChar])
forall a b. (a -> b) -> a -> b
$ Display -> Window -> Window -> IO (Maybe [CChar])
getWindowProperty8 Display
d Window
a Window
w
  Maybe WorkspaceId -> X (Maybe WorkspaceId)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe WorkspaceId -> X (Maybe WorkspaceId))
-> Maybe WorkspaceId -> X (Maybe WorkspaceId)
forall a b. (a -> b) -> a -> b
$ ([CChar] -> WorkspaceId) -> Maybe [CChar] -> Maybe WorkspaceId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CChar -> Char) -> [CChar] -> WorkspaceId
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> (CChar -> Int) -> CChar -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CChar -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral)) Maybe [CChar]
md

-- | Return whether the window will be a floating window or not
willFloat :: Query Bool
willFloat :: Query Bool
willFloat = Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask Query Window -> (Window -> Query Bool) -> Query Bool
forall a b. Query a -> (a -> Query b) -> Query b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Window
w -> X Bool -> Query Bool
forall a. X a -> Query a
liftX (X Bool -> Query Bool) -> X Bool -> Query Bool
forall a b. (a -> b) -> a -> b
$ (Display -> X Bool) -> X Bool
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X Bool) -> X Bool) -> (Display -> X Bool) -> X Bool
forall a b. (a -> b) -> a -> b
$ \Display
d -> Display -> Window -> X Bool
isFixedSizeOrTransient Display
d Window
w

-- | Modify the 'WindowSet' with a pure function.
doF :: (s -> s) -> Query (Endo s)
doF :: forall s. (s -> s) -> Query (Endo s)
doF = Endo s -> Query (Endo s)
forall a. a -> Query a
forall (m :: * -> *) a. Monad m => a -> m a
return (Endo s -> Query (Endo s))
-> ((s -> s) -> Endo s) -> (s -> s) -> Query (Endo s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> s) -> Endo s
forall a. (a -> a) -> Endo a
Endo

-- | Move the window to the floating layer.
doFloat :: ManageHook
doFloat :: ManageHook
doFloat = Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask Query Window -> (Window -> ManageHook) -> ManageHook
forall a b. Query a -> (a -> Query b) -> Query b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Window
w -> (WindowSet -> WindowSet) -> ManageHook
forall s. (s -> s) -> Query (Endo s)
doF ((WindowSet -> WindowSet) -> ManageHook)
-> ((ScreenId, RationalRect) -> WindowSet -> WindowSet)
-> (ScreenId, RationalRect)
-> ManageHook
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> RationalRect -> WindowSet -> WindowSet
forall a i l s sd.
Ord a =>
a -> RationalRect -> StackSet i l a s sd -> StackSet i l a s sd
W.float Window
w (RationalRect -> WindowSet -> WindowSet)
-> ((ScreenId, RationalRect) -> RationalRect)
-> (ScreenId, RationalRect)
-> WindowSet
-> WindowSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScreenId, RationalRect) -> RationalRect
forall a b. (a, b) -> b
snd ((ScreenId, RationalRect) -> ManageHook)
-> Query (ScreenId, RationalRect) -> ManageHook
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< X (ScreenId, RationalRect) -> Query (ScreenId, RationalRect)
forall a. X a -> Query a
liftX (Window -> X (ScreenId, RationalRect)
floatLocation Window
w)

-- | Map the window and remove it from the 'WindowSet'.
doIgnore :: ManageHook
doIgnore :: ManageHook
doIgnore = Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask Query Window -> (Window -> ManageHook) -> ManageHook
forall a b. Query a -> (a -> Query b) -> Query b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Window
w -> X () -> Query ()
forall a. X a -> Query a
liftX (Window -> X ()
reveal Window
w) Query () -> ManageHook -> ManageHook
forall a b. Query a -> Query b -> Query b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (WindowSet -> WindowSet) -> ManageHook
forall s. (s -> s) -> Query (Endo s)
doF (Window -> WindowSet -> WindowSet
forall a i l s sd.
Ord a =>
a -> StackSet i l a s sd -> StackSet i l a s sd
W.delete Window
w)

-- | Move the window to a given workspace
doShift :: WorkspaceId -> ManageHook
doShift :: WorkspaceId -> ManageHook
doShift WorkspaceId
i = (WindowSet -> WindowSet) -> ManageHook
forall s. (s -> s) -> Query (Endo s)
doF ((WindowSet -> WindowSet) -> ManageHook)
-> (Window -> WindowSet -> WindowSet) -> Window -> ManageHook
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorkspaceId -> Window -> WindowSet -> WindowSet
forall a s i l sd.
(Ord a, Eq s, Eq i) =>
i -> a -> StackSet i l a s sd -> StackSet i l a s sd
W.shiftWin WorkspaceId
i (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