{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module       : XMonad.Hooks.XPropManage
-- Description  : ManageHook matching on XProperties.
-- Copyright    : (c) Karsten Schoelzel <kuser@gmx.de>
-- License      : BSD
--
-- Maintainer   : Karsten Schoelzel <kuser@gmx.de>
-- Stability    : unstable
-- Portability  : unportable
--
-- A ManageHook matching on XProperties.
-----------------------------------------------------------------------------

module XMonad.Hooks.XPropManage (
                 -- * Usage
                 -- $usage
                 xPropManageHook, XPropMatch, pmX, pmP
                 ) where

import Control.Exception as E
import Control.Monad.Trans (lift)

import XMonad
import XMonad.Prelude (Endo (..), chr)

-- $usage
-- You can use this module with the following in your @xmonad.hs@:
--
-- > import XMonad.Hooks.XPropManage
-- > import qualified XMonad.StackSet as W
-- > import XMonad.Actions.TagWindows
-- > import Data.List
--
-- > manageHook = xPropManageHook xPropMatches
-- >
-- > xPropMatches :: [XPropMatch]
-- > xPropMatches = [ ([ (wM_CLASS, any ("gimp"==))], (\w -> float w >> return (W.shift "2")))
-- >                , ([ (wM_COMMAND, any ("screen" ==)), (wM_CLASS, any ("xterm" ==))], pmX (addTag "screen"))
-- >                , ([ (wM_NAME, any ("Iceweasel" `isInfixOf`))], pmP (W.shift "3"))
-- >                ]
--
-- Properties known to work: wM_CLASS, wM_NAME, wM_COMMAND
--
-- A XPropMatch consists of a list of conditions and function telling what to do.
--
-- The list entries are pairs of an XProperty to match on (like wM_CLASS, wM_NAME)^1,
-- and an function which matches onto the value of the property (represented as a List
-- of Strings).
--
-- If a match succeeds the function is called immediately, can perform any action and then return
-- a function to apply in 'windows' (see Operations.hs). So if the action does only work on the
-- WindowSet use just 'pmP function'.
--
-- \*1 You can get the available properties of an application with the xprop utility. STRING properties
-- should work fine. Others might not work.
--

type XPropMatch = ([(Atom, [String] -> Bool)], Window -> X (WindowSet -> WindowSet))

pmX :: (Window -> X ()) -> Window -> X (WindowSet -> WindowSet)
pmX :: (Window -> X ()) -> Window -> X (WindowSet -> WindowSet)
pmX Window -> X ()
f Window
w = Window -> X ()
f Window
w X () -> X (WindowSet -> WindowSet) -> X (WindowSet -> WindowSet)
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (WindowSet -> WindowSet) -> X (WindowSet -> WindowSet)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return WindowSet -> WindowSet
forall a. a -> a
id

pmP :: (WindowSet -> WindowSet) -> Window -> X (WindowSet -> WindowSet)
pmP :: (WindowSet -> WindowSet) -> Window -> X (WindowSet -> WindowSet)
pmP WindowSet -> WindowSet
f Window
_ = (WindowSet -> WindowSet) -> X (WindowSet -> WindowSet)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return WindowSet -> WindowSet
f

xPropManageHook :: [XPropMatch] -> ManageHook
xPropManageHook :: [XPropMatch] -> ManageHook
xPropManageHook [XPropMatch]
tms = [ManageHook] -> ManageHook
forall a. Monoid a => [a] -> a
mconcat ([ManageHook] -> ManageHook) -> [ManageHook] -> ManageHook
forall a b. (a -> b) -> a -> b
$ (XPropMatch -> ManageHook) -> [XPropMatch] -> [ManageHook]
forall a b. (a -> b) -> [a] -> [b]
map XPropMatch -> ManageHook
forall {t :: * -> *} {a}.
Traversable t =>
(t (Window, [String] -> Bool), Window -> X (a -> a))
-> Query (Endo a)
propToHook [XPropMatch]
tms
    where
      propToHook :: (t (Window, [String] -> Bool), Window -> X (a -> a))
-> Query (Endo a)
propToHook (t (Window, [String] -> Bool)
ms, Window -> X (a -> a)
f) = (t Bool -> Bool) -> Query (t Bool) -> Query Bool
forall a b. (a -> b) -> Query a -> Query b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (((Window, [String] -> Bool) -> Query Bool)
-> t (Window, [String] -> Bool) -> Query (t Bool)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
mapM (Window, [String] -> Bool) -> Query Bool
forall {b}. (Window, [String] -> b) -> Query b
mkQuery t (Window, [String] -> Bool)
ms) Query Bool -> Query (Endo a) -> Query (Endo a)
forall (m :: * -> *) a. (Monad m, Monoid a) => m Bool -> m a -> m a
--> (Window -> X (a -> a)) -> Query (Endo a)
forall {a}. (Window -> X (a -> a)) -> Query (Endo a)
mkHook Window -> X (a -> a)
f
      mkQuery :: (Window, [String] -> b) -> Query b
mkQuery (Window
a, [String] -> b
tf)    = ([String] -> b) -> Query [String] -> Query b
forall a b. (a -> b) -> Query a -> Query b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [String] -> b
tf (Window -> Query [String]
getQuery Window
a)
      mkHook :: (Window -> X (a -> a)) -> Query (Endo a)
mkHook Window -> X (a -> a)
func        = Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask Query Window -> (Window -> Query (Endo a)) -> Query (Endo a)
forall a b. Query a -> (a -> Query b) -> Query b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT Window X (Endo a) -> Query (Endo a)
forall a. ReaderT Window X a -> Query a
Query (ReaderT Window X (Endo a) -> Query (Endo a))
-> (Window -> ReaderT Window X (Endo a))
-> Window
-> Query (Endo a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. X (Endo a) -> ReaderT Window X (Endo 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 (X (Endo a) -> ReaderT Window X (Endo a))
-> (Window -> X (Endo a)) -> Window -> ReaderT Window X (Endo a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> a) -> Endo a) -> X (a -> a) -> X (Endo a)
forall a b. (a -> b) -> X a -> X b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> a) -> Endo a
forall a. (a -> a) -> Endo a
Endo (X (a -> a) -> X (Endo a))
-> (Window -> X (a -> a)) -> Window -> X (Endo a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> X (a -> a)
func

getProp :: Display -> Window -> Atom -> X [String]
getProp :: Display -> Window -> Window -> X [String]
getProp Display
d Window
w Window
p = do
    [String]
prop <- 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 [String] -> (IOException -> IO [String]) -> IO [String]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch (Display -> Window -> Window -> IO TextProperty
getTextProperty Display
d Window
w Window
p IO TextProperty -> (TextProperty -> IO [String]) -> IO [String]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Display -> TextProperty -> IO [String]
wcTextPropertyToTextList Display
d) (\(IOException
_ :: IOException) -> [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [[]])
    let filt :: Window -> [String] -> [String]
filt Window
q | Window
q Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
wM_COMMAND = (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
splitAtNull
               | Bool
otherwise       = [String] -> [String]
forall a. a -> a
id
    [String] -> X [String]
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Window -> [String] -> [String]
filt Window
p [String]
prop)

getQuery ::  Atom -> Query [String]
getQuery :: Window -> Query [String]
getQuery Window
p = Query Window
forall r (m :: * -> *). MonadReader r m => m r
ask Query Window -> (Window -> Query [String]) -> Query [String]
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 ->  ReaderT Window X [String] -> Query [String]
forall a. ReaderT Window X a -> Query a
Query (ReaderT Window X [String] -> Query [String])
-> (X [String] -> ReaderT Window X [String])
-> X [String]
-> Query [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. X [String] -> ReaderT Window X [String]
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 (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 -> Display -> Window -> Window -> X [String]
getProp Display
d Window
w Window
p

splitAtNull :: String -> [String]
splitAtNull :: String -> [String]
splitAtNull String
s = case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Char
chr Int
0) String
s of
    String
"" -> []
    String
s' -> String
w String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
splitAtNull String
s''
          where (String
w, String
s'') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Char
chr Int
0) String
s'