module XMonad.Util.DebugWindow (debugWindow) where
import Prelude
import XMonad
import XMonad.Prelude
import Codec.Binary.UTF8.String (decodeString)
import Control.Exception as E
import Foreign.C.String
import Numeric (showHex)
import System.Exit
debugWindow :: Window -> X String
debugWindow :: Atom -> X String
debugWindow Atom
0 = String -> X String
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"-no window-"
debugWindow Atom
w = do
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
let wx = Int -> Char -> String -> String
pad Int
8 Char
'0' (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Atom -> String -> String
forall a. Integral a => a -> String -> String
showHex Atom
w String
""
w' <- safeGetWindowAttributes w
case w' of
Maybe WindowAttributes
Nothing ->
String -> X String
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> X String) -> String -> X String
forall a b. (a -> b) -> a -> b
$ String
"(deleted window " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
wx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
Just WindowAttributes
{ wa_x :: WindowAttributes -> CInt
wa_x = CInt
x
, wa_y :: WindowAttributes -> CInt
wa_y = CInt
y
, wa_width :: WindowAttributes -> CInt
wa_width = CInt
wid
, wa_height :: WindowAttributes -> CInt
wa_height = CInt
ht
, wa_border_width :: WindowAttributes -> CInt
wa_border_width = CInt
bw
, wa_map_state :: WindowAttributes -> CInt
wa_map_state = CInt
m
, wa_override_redirect :: WindowAttributes -> Bool
wa_override_redirect = Bool
o
} -> do
c' <- IO (Maybe [CChar]) -> X (Maybe [CChar])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> Atom -> Atom -> IO (Maybe [CChar])
getWindowProperty8 Display
d Atom
wM_CLASS Atom
w)
let c = case Maybe [CChar]
c' of
Maybe [CChar]
Nothing -> String
""
Just [CChar]
c'' -> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
((String -> Maybe (String, String)) -> String -> [String])
-> String -> (String -> Maybe (String, String)) -> [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> Maybe (String, String)) -> String -> [String]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr ((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. Enum a => a -> Int
fromEnum) [CChar]
c'') ((String -> Maybe (String, String)) -> [String])
-> (String -> Maybe (String, String)) -> [String]
forall a b. (a -> b) -> a -> b
$
\String
s -> if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s
then Maybe (String, String)
forall a. Maybe a
Nothing
else let (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
== Char
'\NUL') String
s
s' :: String
s' = Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
s''
in (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
w'',String
s')
t <- catchX' (wrap <$> getEWMHTitle "VISIBLE" w) $
catchX' (wrap <$> getEWMHTitle "" w) $
catchX' (wrap <$> getICCCMTitle w) $
return ""
h' <- getMachine w
let h = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
h' then String
"" else Char
'@'Char -> String -> String
forall a. a -> [a] -> [a]
:String
h'
p' <- safeGetCommand d w
let p = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
p' then String
"" else String -> String
wrap (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String]
p'
nWP <- getAtom "_NET_WM_PID"
pid' <- io $ getWindowProperty32 d nWP w
let pid = case Maybe [CLong]
pid' of
Just [CLong
pid''] -> Char
'('Char -> String -> String
forall a. a -> [a] -> [a]
:CLong -> String
forall a. Show a => a -> String
show CLong
pid'' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
Maybe [CLong]
_ -> String
""
let cmd = String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
h
let (lb,rb) = case () of
() | CInt
m CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
waIsViewable -> (String
"",String
"")
| Bool
otherwise -> (String
"[",String
"]")
o' = if Bool
o then String
"!" else String
""
wT <- getAtom "_NET_WM_WINDOW_TYPE"
wt' <- io $ getWindowProperty32 d wT w
ewmh <- case wt' of
Just [CLong]
wt'' -> Display -> Atom -> [Atom] -> X String
windowType Display
d Atom
w ((CLong -> Atom) -> [CLong] -> [Atom]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CLong -> Atom
forall a b. (Integral a, Num b) => a -> b
fi [CLong]
wt'')
Maybe [CLong]
_ -> String -> X String
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
return $ concat [lb
,o'
,wx
,t
," "
,show wid
,'x':show ht
,if bw == 0 then "" else '+':show bw
,"@"
,show x
,',':show y
,if null c then "" else ' ':c
,if null cmd then "" else ' ':cmd
,ewmh
,rb
]
getEWMHTitle :: String -> Window -> X String
getEWMHTitle :: String -> Atom -> X String
getEWMHTitle String
sub Atom
w = do
a <- String -> X Atom
getAtom (String -> X Atom) -> String -> X Atom
forall a b. (a -> b) -> a -> b
$ String
"_NET_WM_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
sub then String
"" else Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:String
sub) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_NAME"
getDecodedStringProp w a
getICCCMTitle :: Window -> X String
getICCCMTitle :: Atom -> X String
getICCCMTitle Atom
w = Atom -> Atom -> X String
getDecodedStringProp Atom
w Atom
wM_NAME
getDecodedStringProp :: Window -> Atom -> X String
getDecodedStringProp :: Atom -> Atom -> X String
getDecodedStringProp Atom
w Atom
a = do
t@(TextProperty t' _ 8 _) <- (Display -> X TextProperty) -> X TextProperty
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X TextProperty) -> X TextProperty)
-> (Display -> X TextProperty) -> X TextProperty
forall a b. (a -> b) -> a -> b
$ \Display
d -> IO TextProperty -> X TextProperty
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO TextProperty -> X TextProperty)
-> IO TextProperty -> X TextProperty
forall a b. (a -> b) -> a -> b
$ Display -> Atom -> Atom -> IO TextProperty
getTextProperty Display
d Atom
w Atom
a
[s] <- catchX' (tryUTF8 t) $
catchX' (tryCompound t) $
io ((:[]) <$> peekCString t')
return s
tryUTF8 :: TextProperty -> X [String]
tryUTF8 :: TextProperty -> X [String]
tryUTF8 (TextProperty CString
s Atom
enc CInt
_ Atom
_) = do
uTF8_STRING <- String -> X Atom
getAtom String
"UTF8_STRING"
when (enc /= uTF8_STRING) $ error "String is not UTF8_STRING"
map decodeString . splitNul <$> io (peekCAString s)
tryCompound :: TextProperty -> X [String]
tryCompound :: TextProperty -> X [String]
tryCompound t :: TextProperty
t@(TextProperty CString
_ Atom
enc CInt
_ Atom
_) = do
cOMPOUND_TEXT <- String -> X Atom
getAtom String
"COMPOUND_TEXT"
when (enc /= cOMPOUND_TEXT) $ error "String is not COMPOUND_TEXT"
withDisplay $ \Display
d -> 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
$ Display -> TextProperty -> IO [String]
wcTextPropertyToTextList Display
d TextProperty
t
splitNul :: String -> [String]
splitNul :: String -> [String]
splitNul String
"" = []
splitNul String
s = let (String
s',String
ss') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\NUL') String
s in String
s' String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
splitNul String
ss'
pad :: Int -> Char -> String -> String
pad :: Int -> Char -> String -> String
pad Int
w Char
c String
s = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
catchX' :: X a -> X a -> X a
catchX' :: forall a. X a -> X a -> X a
catchX' X a
job X a
errcase = do
st <- X XState
forall s (m :: * -> *). MonadState s m => m s
get
c <- ask
(a, s') <- io $ runX c st job `E.catch` \SomeException
e -> case SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
Just ExitCode
x -> SomeException -> IO (a, XState)
forall a e. (HasCallStack, Exception e) => e -> a
throw SomeException
e IO (a, XState) -> ExitCode -> IO (a, XState)
forall a b. a -> b -> a
`const` (ExitCode
x ExitCode -> ExitCode -> ExitCode
forall a. a -> a -> a
`asTypeOf` ExitCode
ExitSuccess)
Maybe ExitCode
_ -> XConf -> XState -> X a -> IO (a, XState)
forall a. XConf -> XState -> X a -> IO (a, XState)
runX XConf
c XState
st X a
errcase
put s'
return a
wrap :: String -> String
wrap :: String -> String
wrap String
s = Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'"' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
wrap' String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
where
wrap' :: String -> String
wrap' (Char
s':String
ss) | Char
s' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
s' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
wrap' String
ss
| Char
s' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
s' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
wrap' String
ss
| Bool
otherwise = Char
s' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
wrap' String
ss
wrap' String
"" = String
""
safeGetCommand :: Display -> Window -> X [String]
safeGetCommand :: Display -> Atom -> X [String]
safeGetCommand Display
d Atom
w = do
wC <- String -> X Atom
getAtom String
"WM_COMMAND"
p <- io $ getWindowProperty8 d wC w
case p of
Maybe [CChar]
Nothing -> [String] -> X [String]
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just [CChar]
cs' -> do
let cs :: String
cs = (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. Enum a => a -> Int
fromEnum) [CChar]
cs'
go :: ([String], (String, String)) -> ([String], (String, String))
go ([String]
a,(String
s,String
"\NUL")) = (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
a,(String
"",String
""))
go ([String]
a,(String
s,Char
'\NUL':String
ss)) = ([String], (String, String)) -> ([String], (String, String))
go (String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
a,String -> (String, String)
go' String
ss)
go ([String], (String, String))
r = ([String], (String, String))
r
go' :: String -> (String, String)
go' = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\NUL')
in [String] -> X [String]
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> X [String]) -> [String] -> X [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ ([String], (String, String)) -> [String]
forall a b. (a, b) -> a
fst (([String], (String, String)) -> [String])
-> ([String], (String, String)) -> [String]
forall a b. (a -> b) -> a -> b
$ ([String], (String, String)) -> ([String], (String, String))
go ([],String -> (String, String)
go' String
cs)
getMachine :: Window -> X String
getMachine :: Atom -> X String
getMachine Atom
w = X String -> X String -> X String
forall a. X a -> X a -> X a
catchX' (String -> X Atom
getAtom String
"WM_CLIENT_MACHINE" X Atom -> (Atom -> X String) -> X String
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Atom -> Atom -> X String
getDecodedStringProp Atom
w) (String -> X String
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"")
windowType :: Display -> Window -> [Atom] -> X String
windowType :: Display -> Atom -> [Atom] -> X String
windowType Display
d Atom
w [Atom]
ts = do
tstr <- [Atom] -> X String
decodeType [Atom]
ts
wS <- getAtom "_NET_WM_STATE"
ss' <- io $ getWindowProperty32 d wS w
sstr <- case ss' of
Just [CLong]
ss -> [Atom] -> X String
windowState ((CLong -> Atom) -> [CLong] -> [Atom]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CLong -> Atom
forall a b. (Integral a, Num b) => a -> b
fi [CLong]
ss)
Maybe [CLong]
_ -> String -> X String
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
return $ " (" ++ tstr ++ sstr ++ ")"
where
decodeType :: [Atom] -> X String
decodeType :: [Atom] -> X String
decodeType [] = String -> X String
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
decodeType [Atom
t] = String -> Atom -> X String
simplify String
"_NET_WM_WINDOW_TYPE_" Atom
t
decodeType [Atom]
tys = [Atom] -> String -> Bool -> X String
unAtoms [Atom]
tys String
" (" Bool
False
unAtoms :: [Atom] -> String -> Bool -> X String
unAtoms :: [Atom] -> String -> Bool -> X String
unAtoms [] String
t Bool
i = String -> X String
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> X String) -> String -> X String
forall a b. (a -> b) -> a -> b
$ if Bool
i then String
t else String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
unAtoms (Atom
a:[Atom]
as) String
t Bool
i = do
s' <- IO (Maybe String) -> X (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe String) -> X (Maybe String))
-> IO (Maybe String) -> X (Maybe String)
forall a b. (a -> b) -> a -> b
$ Display -> Atom -> IO (Maybe String)
getAtomName Display
d Atom
a
let s = case Maybe String
s' of
Just String
s'' -> String
s''
Maybe String
_ -> Char
'<'Char -> String -> String
forall a. a -> [a] -> [a]
:Atom -> String
forall a. Show a => a -> String
show Atom
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
unAtoms as (t ++ (if i then ' ':s else s)) True
simplify :: String -> Atom -> X String
simplify :: String -> Atom -> X String
simplify String
pfx Atom
a = do
s' <- IO (Maybe String) -> X (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe String) -> X (Maybe String))
-> IO (Maybe String) -> X (Maybe String)
forall a b. (a -> b) -> a -> b
$ Display -> Atom -> IO (Maybe String)
getAtomName Display
d Atom
a
case s' of
Maybe String
Nothing -> String -> X String
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> X String) -> String -> X String
forall a b. (a -> b) -> a -> b
$ Char
'<'Char -> String -> String
forall a. a -> [a] -> [a]
:Atom -> String
forall a. Show a => a -> String
show Atom
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
Just String
s -> if String
pfx String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s then
String -> X String
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> X String) -> String -> X String
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pfx) String
s)
else
String -> X String
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return String
s
windowState :: [Atom] -> X String
windowState :: [Atom] -> X String
windowState [] = String -> X String
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
windowState [Atom]
as' = [Atom] -> String -> X String
go [Atom]
as' String
";"
where
go :: [Atom] -> String -> X String
go [] String
t = String -> X String
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return String
t
go (Atom
a:[Atom]
as) String
t = String -> Atom -> X String
simplify String
"_NET_WM_STATE_" Atom
a X String -> (String -> X String) -> X String
forall a b. X a -> (a -> X b) -> X b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
t' -> [Atom] -> String -> X String
go [Atom]
as (String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:String
t')