-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Util.DebugWindow
-- Copyright   :  (c) Brandon S Allbery KF8NH, 2012
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  allbery.b@gmail.com
-- Stability   :  unstable
-- Portability :  not portable
--
-- Module to dump window information for diagnostic/debugging purposes.  See 
-- "XMonad.Hooks.DebugEvents" and "XMonad.Hooks.DebugStack" for practical uses.
--
-----------------------------------------------------------------------------

module XMonad.Util.DebugWindow (debugWindow) where

import           Prelude

import           XMonad

import           Codec.Binary.UTF8.String        (decodeString)
import           Control.Exception.Extensible as E
import           Control.Monad                   (when)
import           Data.List                       (unfoldr
                                                 ,intercalate
                                                 )
import           Foreign
import           Foreign.C.String
import           Numeric                         (showHex)
import           System.Exit

-- | Output a window by ID in hex, decimal, its ICCCM resource name and class,
--   and its title if available.  Also indicate override_redirect with an
--   exclamation mark, and wrap in brackets if it is unmapped or withdrawn.
debugWindow   :: Window -> X String
debugWindow 0 =  return "None"
debugWindow w =  do
  let wx = pad 8 '0' $ showHex w ""
  w' <- withDisplay $ \d -> io (safeGetWindowAttributes d w)
  case w' of
    Nothing                                   ->
      return $ "(deleted window " ++ wx ++ ")"
    Just (WindowAttributes x y wid ht bw m o) -> do
      c' <- withDisplay $ \d ->
            io (getWindowProperty8 d wM_CLASS w)
      let c = case c' of
                Nothing -> ""
                Just c''  -> intercalate "/" $
                             flip unfoldr (map (toEnum . fromEnum) c'') $
                             \s -> if null s
                                     then Nothing
                                     else let (w'',s'') = break (== '\NUL') s
                                              s'      = if null s''
                                                          then s''
                                                          else tail s''
                                          in Just (w'',s')
      t <- catchX' (wrap `fmap` getEWMHTitle  "VISIBLE" w) $
           catchX' (wrap `fmap` getEWMHTitle  ""        w) $
           catchX' (wrap `fmap` getICCCMTitle           w) $
           return ""
      let (lb,rb) = case () of
                      () | m == waIsViewable -> ("","")
                         | otherwise         -> ("[","]")
          o'      = if o then "!" else ""
      return $ concat [lb
                      ,o'
                      ,"window "
                      ,wx
                      ,t
                      ," ("
                      ,show wid
                      ,',':show ht
                      ,')':if bw == 0 then "" else '+':show bw
                      ,"@("
                      ,show x
                      ,',':show y
                      ,')':if null c then "" else ' ':c
                      ,rb
                      ]

getEWMHTitle       :: String -> Window -> X String
getEWMHTitle sub w =  do
  a <- getAtom $ "_NET_WM_" ++ (if null sub then "" else '_':sub) ++ "_NAME"
  (Just t) <- withDisplay $ \d -> io $ getWindowProperty32 d a w
  return $ map (toEnum . fromEnum) t

getICCCMTitle   :: Window -> X String
getICCCMTitle w =  do
  t@(TextProperty t' _ 8 _) <- withDisplay $ \d -> io $ getTextProperty d w wM_NAME
  [s] <- catchX' (tryUTF8     t) $
         catchX' (tryCompound t) $
         io ((:[]) `fmap` peekCString t')
  return s

tryUTF8                          :: TextProperty -> X [String]
tryUTF8 (TextProperty s enc _ _) =  do
  uTF8_STRING <- getAtom "UTF8_STRING"
  when (enc == uTF8_STRING) $ error "String is not UTF8_STRING"
  (map decodeString . splitNul) `fmap` io (peekCString s)

tryCompound                            :: TextProperty -> X [String]
tryCompound t@(TextProperty _ enc _ _) =  do
  cOMPOUND_TEXT <- getAtom "COMPOUND_TEXT"
  when (enc == cOMPOUND_TEXT) $ error "String is not COMPOUND_TEXT"
  withDisplay $ \d -> io $ wcTextPropertyToTextList d t

splitNul    :: String -> [String]
splitNul "" =  []
splitNul s  =  let (s',ss') = break (== '\NUL') s in s' : splitNul ss'

pad       :: Int -> Char -> String -> String
pad w c s =  replicate (w - length s) c ++ s

-- modified 'catchX' without the print to 'stderr'
catchX' :: X a -> X a -> X a
catchX' job errcase = do
  st <- get
  c <- ask
  (a, s') <- io $ runX c st job `E.catch` \e -> case fromException e of
    Just x -> throw e `const` (x `asTypeOf` ExitSuccess)
    _ -> runX c st errcase
  put s'
  return a

wrap   :: String -> String
wrap s =  ' ' : '"' : wrap' s ++ "\""
  where
    wrap' (s':ss) | s' == '"'  = '\\' : s' : wrap' ss
                  | s' == '\\' = '\\' : s' : wrap' ss
                  | otherwise  =        s' : wrap' ss
    wrap' ""                   =             ""

-- Graphics.X11.Extras.getWindowAttributes is bugggggggy
safeGetWindowAttributes     :: Display -> Window -> IO (Maybe WindowAttributes)
safeGetWindowAttributes d w =  alloca $ \p -> do
  s <- xGetWindowAttributes d w p
  case s of
    0 -> return Nothing
    _ -> Just `fmap` peek p