blob: 8dad7040ee49d00c2fa9bfebb1f82e49b460f6f0 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module : MetaTile.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 MetaTile.ManageHook where
import MetaTile.Core
import Graphics.X11.Xlib.Extras
import Graphics.X11.Xlib (Display, internAtom, wM_NAME)
import Control.Exception.Extensible (bracket, SomeException(..))
import Control.Monad.Reader
import Data.Maybe
import Data.Monoid
import qualified MetaTile.StackSet as W
import MetaTile.Operations (reveal)
import qualified Control.Exception.Extensible as C (catch)
-- | Lift an 'X' action to a 'Query'.
liftX :: X a -> Query a
liftX = Query . lift
-- | The identity hook that returns the WindowSet unchanged.
idHook :: Monoid m => m
idHook = mempty
-- | Infix 'mappend'. Compose two 'ManageHook' from right to left.
(<+>) :: Monoid m => m -> m -> m
(<+>) = mappend
-- | Compose the list of 'ManageHook's.
composeAll :: Monoid m => [m] -> m
composeAll = 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
p --> f = p >>= \b -> if b then f else return mempty
-- | @q =? x@. if the result of @q@ equals @x@, return 'True'.
(=?) :: Eq a => Query a -> a -> Query Bool
q =? x = fmap (== x) q
infixr 3 <&&>, <||>
-- | '&&' lifted to a 'Monad'.
(<&&>) :: Monad m => m Bool -> m Bool -> m Bool
(<&&>) = liftM2 (&&)
-- | '||' lifted to a 'Monad'.
(<||>) :: Monad m => m Bool -> m Bool -> m Bool
(<||>) = liftM2 (||)
-- | Return the window title.
title :: Query String
title = ask >>= \w -> liftX $ do
d <- asks display
let
getProp =
(internAtom d "_NET_WM_NAME" False >>= getTextProperty d w)
`C.catch` \(SomeException _) -> getTextProperty d w wM_NAME
extract prop = do l <- wcTextPropertyToTextList d prop
return $ if null l then "" else head l
io $ bracket getProp (xFree . tp_value) extract `C.catch` \(SomeException _) -> return ""
-- | Return the application name.
appName :: Query String
appName = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resName $ io $ getClassHint d w)
-- | Backwards compatible alias for 'appName'.
resource :: Query String
resource = appName
-- | Return the resource class.
className :: Query String
className = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap resClass $ io $ getClassHint d w)
-- | A query that can return an arbitrary X property of type 'String',
-- identified by name.
stringProperty :: String -> Query String
stringProperty p = ask >>= (\w -> liftX $ withDisplay $ \d -> fmap (fromMaybe "") $ getStringProperty d w p)
getStringProperty :: Display -> Window -> String -> X (Maybe String)
getStringProperty d w p = do
a <- getAtom p
md <- io $ getWindowProperty8 d a w
return $ fmap (map (toEnum . fromIntegral)) md
-- | Modify the 'WindowSet' with a pure function.
doF :: (s -> s) -> Query (Endo s)
doF = return . Endo
-- | Map the window and remove it from the 'WindowSet'.
doIgnore :: ManageHook
doIgnore = ask >>= \w -> liftX (reveal w) >> doF (W.delete w)
-- | Move the window to a given workspace
doShift :: WorkspaceId -> ManageHook
doShift i = doF . W.shiftWin i =<< ask
|
