-----------------------------------------------------------------------------
-- |
-- 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 = forall a. ReaderT Window X a -> Query a
Query forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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
(<+>) = 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 = 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> if Bool
b then m a
f else forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 = forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
x m Bool
y (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 = forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM m Bool
x (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 = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Window
w -> forall a. X a -> Query a
liftX forall a b. (a -> b) -> a -> b
$ do
    Display
d <- 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Display -> Window -> Window -> IO TextProperty
getTextProperty Display
d Window
w)
                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
                          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe WorkspaceId
"" forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe [WorkspaceId]
l
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO TextProperty
getProp (forall a. Ptr a -> IO CInt
xFree forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextProperty -> CString
tp_value) TextProperty -> IO WorkspaceId
extract forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException e
_) -> 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 = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Window
w -> forall a. X a -> Query a
liftX forall a b. (a -> b) -> a -> b
$ forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
d -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ClassHint -> WorkspaceId
resName forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
io 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 = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Window
w -> forall a. X a -> Query a
liftX forall a b. (a -> b) -> a -> b
$ forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
d -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ClassHint -> WorkspaceId
resClass forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
io 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 = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Window
w -> forall a. X a -> Query a
liftX forall a b. (a -> b) -> a -> b
$ forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
d -> forall a. a -> Maybe a -> a
fromMaybe 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> Window -> Window -> IO (Maybe [CChar])
getWindowProperty8 Display
d Window
a Window
w
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Window
w -> forall a. X a -> Query a
liftX forall a b. (a -> b) -> a -> b
$ forall a. (Display -> X a) -> X a
withDisplay 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a) -> Endo a
Endo

-- | Move the window to the floating layer.
doFloat :: ManageHook
doFloat :: ManageHook
doFloat = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Window
w -> forall s. (s -> s) -> Query (Endo s)
doF forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 = forall r (m :: * -> *). MonadReader r m => m r
ask forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Window
w -> forall a. X a -> Query a
liftX (Window -> X ()
reveal Window
w) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s. (s -> s) -> Query (Endo s)
doF (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 = forall s. (s -> s) -> Query (Endo s)
doF forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *). MonadReader r m => m r
ask