content: -----------------------------------------------------------------------------
  -- |
  -- Module      :  XMonad.Util.DebugWindow
  -- Copyright   :  (c) Brandon S Allbery KF8NH, 2014
  -- 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 "-no window-"
  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 ""
        h' <- getMachine w
        let h = if null h' then "" else '@':h'
        -- if it has WM_COMMAND use it, else use the appName
        -- NB. modern stuff often does not set WM_COMMAND since it's only ICCCM required and not some
        -- horrible gnome/freedesktop session manager thing like Wayland intended. How helpful of them.
        p' <- withDisplay $ \d -> safeGetCommand d w
        let p = if null p' then "" else wrap $ intercalate " " p'
        nWP <- getAtom "_NET_WM_PID"
        pid' <- withDisplay $ \d -> io $ getWindowProperty32 d nWP w
        let pid = case pid' of
                    Just [pid''] -> '(':show pid'' ++ ")"
                    _            -> ""
        let cmd = p ++ pid ++ h
        let (lb,rb) = case () of
                        () | m == waIsViewable -> ("","")
                           | otherwise         -> ("[","]")
            o'      = if o then "!" else ""
        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 
                        ,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 =  getDecodedStringProp w wM_NAME
  
  getDecodedStringProp     :: Window -> Atom -> X String
  getDecodedStringProp w a =  do
    t@(TextProperty t' _ 8 _) <- withDisplay $ \d -> io $ getTextProperty d w a
    [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
  
  -- and so is getCommand
  safeGetCommand     :: Display -> Window -> X [String]
  safeGetCommand d w =  do
    wC <- getAtom "WM_COMMAND"
    p <- io $ getWindowProperty8 d wC w
    case p of
      Nothing  -> return []
      Just cs' -> do
        let cs                    = map (toEnum . fromEnum) cs'
            go  (a,(s,"\NUL"))    = (s:a,("",""))
            go  (a,(s,'\NUL':ss)) = go (s:a,go' ss)
            go  r                 = r -- ???
            go'                   = break (== '\NUL')
         in return $ reverse $ fst $ go ([],go' cs)
  
  getMachine   :: Window -> X String
  getMachine w =  catchX' (getAtom "WM_CLIENT_MACHINE" >>= getDecodedStringProp w) (return "")
  