{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.ManageHook
-- Copyright   :  (c) Spencer Janssen 2007
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  spencerjanssen@gmail.com
-- Stability   :  unstable
-- Portability :  not portable, uses cunning newtype deriving
--
-- 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)

-- | Lift an 'X' action to a 'Query'.
liftX :: X a -> Query a
liftX :: 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 (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 :: m
idHook = m
forall a. Monoid a => a
mempty

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

-- | Compose the list of 'ManageHook's.
composeAll :: Monoid m => [m] -> m
composeAll :: [m] -> m
composeAll = [m] -> m
forall a. Monoid a => [a] -> a
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 --> :: m Bool -> m a -> m a
--> m a
f = m Bool
p m Bool -> (Bool -> m a) -> m a
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 (m :: * -> *) a. Monad m => a -> m a
return a
forall a. Monoid a => a
mempty

-- | @q =? x@. if the result of @q@ equals @x@, return 'True'.
(=?) :: Eq a => Query a -> a -> Query Bool
Query a
q =? :: Query a -> a -> Query Bool
=? a
x = (a -> Bool) -> Query a -> Query Bool
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 -> m Bool -> m Bool
(<&&>) m Bool
x 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 (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)

-- | '||' lifted to a 'Monad'.
(<||>) :: Monad m => m Bool -> m Bool -> m Bool
<||> :: m Bool -> m Bool -> m Bool
(<||>) m Bool
x 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 (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) m Bool
y

-- | If-then-else lifted to a 'Monad'.
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM :: m Bool -> m a -> m a -> m a
ifM m Bool
mb m a
t m a
f = m Bool
mb m Bool -> (Bool -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> if Bool
b then m a
t else m a
f

-- | Return the window title.
title :: Query String
title :: Query String
title = Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask Query Window -> (Window -> Query String) -> Query String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Window
w -> X String -> Query String
forall a. X a -> Query a
liftX (X String -> Query String) -> X String -> Query String
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 -> String -> Bool -> IO Window
internAtom Display
d String
"_NET_WM_NAME" Bool
False IO Window -> (Window -> IO TextProperty) -> IO TextProperty
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 String
extract TextProperty
prop = do [String]
l <- Display -> TextProperty -> IO [String]
wcTextPropertyToTextList Display
d TextProperty
prop
                          String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
l then String
"" else [String] -> String
forall a. [a] -> a
head [String]
l
    IO String -> X String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO String -> X String) -> IO String -> X String
forall a b. (a -> b) -> a -> b
$ IO TextProperty
-> (TextProperty -> IO CInt)
-> (TextProperty -> IO String)
-> IO String
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 String
extract IO String -> (SomeException -> IO String) -> IO String
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException e
_) -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""

-- | Return the application name.
appName :: Query String
appName :: Query String
appName = Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask Query Window -> (Window -> Query String) -> Query String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Window
w -> X String -> Query String
forall a. X a -> Query a
liftX (X String -> Query String) -> X String -> Query String
forall a b. (a -> b) -> a -> b
$ (Display -> X String) -> X String
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X String) -> X String)
-> (Display -> X String) -> X String
forall a b. (a -> b) -> a -> b
$ \Display
d -> (ClassHint -> String) -> X ClassHint -> X String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ClassHint -> String
resName (X ClassHint -> X String) -> X ClassHint -> X String
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 String
resource = Query String
appName

-- | Return the resource class.
className :: Query String
className :: Query String
className = Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask Query Window -> (Window -> Query String) -> Query String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Window
w -> X String -> Query String
forall a. X a -> Query a
liftX (X String -> Query String) -> X String -> Query String
forall a b. (a -> b) -> a -> b
$ (Display -> X String) -> X String
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X String) -> X String)
-> (Display -> X String) -> X String
forall a b. (a -> b) -> a -> b
$ \Display
d -> (ClassHint -> String) -> X ClassHint -> X String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ClassHint -> String
resClass (X ClassHint -> X String) -> X ClassHint -> X String
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 :: String -> Query String
stringProperty String
p = Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask Query Window -> (Window -> Query String) -> Query String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Window
w -> X String -> Query String
forall a. X a -> Query a
liftX (X String -> Query String) -> X String -> Query String
forall a b. (a -> b) -> a -> b
$ (Display -> X String) -> X String
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X String) -> X String)
-> (Display -> X String) -> X String
forall a b. (a -> b) -> a -> b
$ \Display
d -> (Maybe String -> String) -> X (Maybe String) -> X String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"") (X (Maybe String) -> X String) -> X (Maybe String) -> X String
forall a b. (a -> b) -> a -> b
$ Display -> Window -> String -> X (Maybe String)
getStringProperty Display
d Window
w String
p)

getStringProperty :: Display -> Window -> String -> X (Maybe String)
getStringProperty :: Display -> Window -> String -> X (Maybe String)
getStringProperty Display
d Window
w String
p = do
  Window
a  <- String -> X Window
getAtom String
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 String -> X (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> X (Maybe String))
-> Maybe String -> X (Maybe String)
forall a b. (a -> b) -> a -> b
$ ([CChar] -> String) -> Maybe [CChar] -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CChar -> Char) -> [CChar] -> String
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

-- | Modify the 'WindowSet' with a pure function.
doF :: (s -> s) -> Query (Endo s)
doF :: (s -> s) -> Query (Endo s)
doF = Endo s -> Query (Endo s)
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Window
w -> (StackSet String (Layout Window) Window ScreenId ScreenDetail
 -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> ManageHook
forall s. (s -> s) -> Query (Endo s)
doF ((StackSet String (Layout Window) Window ScreenId ScreenDetail
  -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
 -> ManageHook)
-> ((ScreenId, RationalRect)
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> (ScreenId, RationalRect)
-> ManageHook
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window
-> RationalRect
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
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
 -> StackSet String (Layout Window) Window ScreenId ScreenDetail
 -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> ((ScreenId, RationalRect) -> RationalRect)
-> (ScreenId, RationalRect)
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (StackSet String (Layout Window) Window ScreenId ScreenDetail
 -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> ManageHook
forall s. (s -> s) -> Query (Endo s)
doF (Window
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
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 :: String -> ManageHook
doShift String
i = (StackSet String (Layout Window) Window ScreenId ScreenDetail
 -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> ManageHook
forall s. (s -> s) -> Query (Endo s)
doF ((StackSet String (Layout Window) Window ScreenId ScreenDetail
  -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
 -> ManageHook)
-> (Window
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> Window
-> ManageHook
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> Window
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
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 String
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