-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Util.NamedWindows
-- Description :  Associate the X titles of windows with them.
-- Copyright   :  (c) David Roundy <droundy@darcs.net>
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  none
-- Stability   :  unstable
-- Portability :  unportable
--
-- This module allows you to associate the X titles of windows with
-- them.
--
-----------------------------------------------------------------------------

module XMonad.Util.NamedWindows (
                                   -- * Usage
                                   -- $usage
                                   NamedWindow,
                                   getName,
                                   getNameWMClass,
                                   withNamedWindow,
                                   unName
                                  ) where

import Control.Exception as E
import XMonad.Prelude ( fromMaybe, listToMaybe, (>=>) )

import qualified XMonad.StackSet as W ( peek )


import XMonad

-- $usage
-- See "XMonad.Layout.Tabbed" for an example of its use.


data NamedWindow = NW !String !Window
instance Eq NamedWindow where
    (NW String
s Window
_) == :: NamedWindow -> NamedWindow -> Bool
== (NW String
s' Window
_) = String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s'
instance Ord NamedWindow where
    compare :: NamedWindow -> NamedWindow -> Ordering
compare (NW String
s Window
_) (NW String
s' Window
_) = String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare String
s String
s'
instance Show NamedWindow where
    show :: NamedWindow -> String
show (NW String
n Window
_) = String
n

getName :: Window -> X NamedWindow
getName :: Window -> X NamedWindow
getName Window
w = (Display -> X NamedWindow) -> X NamedWindow
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X NamedWindow) -> X NamedWindow)
-> (Display -> X NamedWindow) -> X NamedWindow
forall a b. (a -> b) -> a -> b
$ \Display
d -> do
    -- TODO, this code is ugly and convoluted -- clean it up
    let getIt :: IO NamedWindow
getIt = IO TextProperty
-> (TextProperty -> IO CInt)
-> (TextProperty -> IO NamedWindow)
-> IO NamedWindow
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) ((String -> NamedWindow) -> IO String -> IO NamedWindow
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Window -> NamedWindow
`NW` Window
w) (IO String -> IO NamedWindow)
-> (TextProperty -> IO String) -> TextProperty -> IO NamedWindow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextProperty -> IO String
copy)

        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

        copy :: TextProperty -> IO String
copy TextProperty
prop = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String)
-> ([String] -> Maybe String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> String) -> IO [String] -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> TextProperty -> IO [String]
wcTextPropertyToTextList Display
d TextProperty
prop

    IO NamedWindow -> X NamedWindow
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO NamedWindow -> X NamedWindow)
-> IO NamedWindow -> X NamedWindow
forall a b. (a -> b) -> a -> b
$ IO NamedWindow
getIt IO NamedWindow
-> (SomeException -> IO NamedWindow) -> IO NamedWindow
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException e
_) ->  (String -> Window -> NamedWindow
`NW` Window
w) (String -> NamedWindow)
-> (ClassHint -> String) -> ClassHint -> NamedWindow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassHint -> String
resName (ClassHint -> NamedWindow) -> IO ClassHint -> IO NamedWindow
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> Window -> IO ClassHint
getClassHint Display
d Window
w

-- | Get 'NamedWindow' using 'wM_CLASS'
getNameWMClass :: Window -> X NamedWindow
getNameWMClass :: Window -> X NamedWindow
getNameWMClass Window
w =
  (Display -> X NamedWindow) -> X NamedWindow
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X NamedWindow) -> X NamedWindow)
-> (Display -> X NamedWindow) -> X NamedWindow
forall a b. (a -> b) -> a -> b
$ \Display
d
    -- TODO, this code is ugly and convoluted -- clean it up
   -> do
    let getIt :: IO NamedWindow
getIt = IO TextProperty
-> (TextProperty -> IO CInt)
-> (TextProperty -> IO NamedWindow)
-> IO NamedWindow
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) ((String -> NamedWindow) -> IO String -> IO NamedWindow
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Window -> NamedWindow
`NW` Window
w) (IO String -> IO NamedWindow)
-> (TextProperty -> IO String) -> TextProperty -> IO NamedWindow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextProperty -> IO String
copy)
        getProp :: IO TextProperty
getProp = Display -> Window -> Window -> IO TextProperty
getTextProperty Display
d Window
w Window
wM_CLASS
        copy :: TextProperty -> IO String
copy TextProperty
prop =
          String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String)
-> ([String] -> Maybe String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> String) -> IO [String] -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> TextProperty -> IO [String]
wcTextPropertyToTextList Display
d TextProperty
prop
    IO NamedWindow -> X NamedWindow
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO NamedWindow -> X NamedWindow)
-> IO NamedWindow -> X NamedWindow
forall a b. (a -> b) -> a -> b
$
      IO NamedWindow
getIt IO NamedWindow
-> (SomeException -> IO NamedWindow) -> IO NamedWindow
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException e
_) ->
        (String -> Window -> NamedWindow
`NW` Window
w) (String -> NamedWindow)
-> (ClassHint -> String) -> ClassHint -> NamedWindow
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClassHint -> String
resName (ClassHint -> NamedWindow) -> IO ClassHint -> IO NamedWindow
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> Window -> IO ClassHint
getClassHint Display
d Window
w

unName :: NamedWindow -> Window
unName :: NamedWindow -> Window
unName (NW String
_ Window
w) = Window
w

withNamedWindow :: (NamedWindow -> X ()) -> X ()
withNamedWindow :: (NamedWindow -> X ()) -> X ()
withNamedWindow NamedWindow -> X ()
f = do WindowSet
ws <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
                       Maybe Window -> (Window -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (WindowSet -> Maybe Window
forall i l a s sd. StackSet i l a s sd -> Maybe a
W.peek WindowSet
ws) (Window -> X NamedWindow
getName (Window -> X NamedWindow)
-> (NamedWindow -> X ()) -> Window -> X ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> NamedWindow -> X ()
f)