{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Plugins.StdinReader
-- Copyright   :  (c) Spencer Janssen
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Spencer Janssen <spencerjanssen@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- A plugin to display information from _XMONAD_LOG, specified at
-- http://code.haskell.org/XMonadContrib/XMonad/Hooks/DynamicLog.hs
--
-----------------------------------------------------------------------------

module Xmobar.Plugins.XMonadLog (XMonadLog(..)) where

import Control.Monad
import Graphics.X11
import Graphics.X11.Xlib.Extras
import Xmobar.Run.Exec
import Xmobar.Run.Actions (stripActions)

#ifdef UTF8
#undef UTF8
import Codec.Binary.UTF8.String as UTF8
#define UTF8
#endif

import Foreign.C (CChar)
import Data.List (intercalate)
import Xmobar.X11.Events (nextEvent')

data XMonadLog = XMonadLog
               | UnsafeXMonadLog
               | XPropertyLog String
               | UnsafeXPropertyLog String
               | NamedXPropertyLog String String
               | UnsafeNamedXPropertyLog String String
    deriving (ReadPrec [XMonadLog]
ReadPrec XMonadLog
Int -> ReadS XMonadLog
ReadS [XMonadLog]
(Int -> ReadS XMonadLog)
-> ReadS [XMonadLog]
-> ReadPrec XMonadLog
-> ReadPrec [XMonadLog]
-> Read XMonadLog
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [XMonadLog]
$creadListPrec :: ReadPrec [XMonadLog]
readPrec :: ReadPrec XMonadLog
$creadPrec :: ReadPrec XMonadLog
readList :: ReadS [XMonadLog]
$creadList :: ReadS [XMonadLog]
readsPrec :: Int -> ReadS XMonadLog
$creadsPrec :: Int -> ReadS XMonadLog
Read, Int -> XMonadLog -> ShowS
[XMonadLog] -> ShowS
XMonadLog -> String
(Int -> XMonadLog -> ShowS)
-> (XMonadLog -> String)
-> ([XMonadLog] -> ShowS)
-> Show XMonadLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XMonadLog] -> ShowS
$cshowList :: [XMonadLog] -> ShowS
show :: XMonadLog -> String
$cshow :: XMonadLog -> String
showsPrec :: Int -> XMonadLog -> ShowS
$cshowsPrec :: Int -> XMonadLog -> ShowS
Show)

instance Exec XMonadLog where
    alias :: XMonadLog -> String
alias XMonadLog
XMonadLog = String
"XMonadLog"
    alias XMonadLog
UnsafeXMonadLog = String
"UnsafeXMonadLog"
    alias (XPropertyLog String
atom) = String
atom
    alias (NamedXPropertyLog String
_ String
name) = String
name
    alias (UnsafeXPropertyLog String
atom) = String
atom
    alias (UnsafeNamedXPropertyLog String
_ String
name) = String
name

    start :: XMonadLog -> (String -> IO ()) -> IO ()
start XMonadLog
x String -> IO ()
cb = do
        let atom :: String
atom = case XMonadLog
x of
                XMonadLog
XMonadLog -> String
"_XMONAD_LOG"
                XMonadLog
UnsafeXMonadLog -> String
"_XMONAD_LOG"
                XPropertyLog String
a -> String
a
                UnsafeXPropertyLog String
a -> String
a
                NamedXPropertyLog String
a String
_ -> String
a
                UnsafeNamedXPropertyLog String
a String
_ -> String
a
            stripNL :: ShowS
stripNL = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" - " ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
            sanitize :: ShowS
sanitize = case XMonadLog
x of
                XMonadLog
UnsafeXMonadLog -> ShowS
forall a. a -> a
id
                UnsafeXPropertyLog String
_ -> ShowS
forall a. a -> a
id
                UnsafeNamedXPropertyLog String
_ String
_ -> ShowS
forall a. a -> a
id
                XMonadLog
_ -> ShowS
stripActions ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
stripNL

        Display
d <- String -> IO Display
openDisplay String
""
        Atom
xlog <- Display -> String -> Bool -> IO Atom
internAtom Display
d String
atom Bool
False

        Atom
root  <- Display -> ScreenNumber -> IO Atom
rootWindow Display
d (Display -> ScreenNumber
defaultScreen Display
d)
        Display -> Atom -> Atom -> IO ()
selectInput Display
d Atom
root Atom
propertyChangeMask

        let update :: IO ()
update = do
                        Maybe [CChar]
mwp <- Display -> Atom -> Atom -> IO (Maybe [CChar])
getWindowProperty8 Display
d Atom
xlog Atom
root
                        IO () -> ([CChar] -> IO ()) -> Maybe [CChar] -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (String -> IO ()
cb (String -> IO ()) -> ([CChar] -> String) -> [CChar] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
sanitize ShowS -> ([CChar] -> String) -> [CChar] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CChar] -> String
decodeCChar) Maybe [CChar]
mwp

        IO ()
update

        (XEventPtr -> IO Any) -> IO Any
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO Any) -> IO Any)
-> (XEventPtr -> IO Any) -> IO Any
forall a b. (a -> b) -> a -> b
$ \XEventPtr
ep -> IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ do
            Display -> XEventPtr -> IO ()
nextEvent' Display
d XEventPtr
ep
            Event
e <- XEventPtr -> IO Event
getEvent XEventPtr
ep
            case Event
e of
                PropertyEvent { ev_atom :: Event -> Atom
ev_atom = Atom
a } | Atom
a Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
==  Atom
xlog -> IO ()
update
                Event
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

decodeCChar :: [CChar] -> String
#ifdef UTF8
#undef UTF8
decodeCChar :: [CChar] -> String
decodeCChar = [Word8] -> String
UTF8.decode ([Word8] -> String) -> ([CChar] -> [Word8]) -> [CChar] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CChar -> Word8) -> [CChar] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map CChar -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral
#define UTF8
#else
decodeCChar = map (toEnum . fromIntegral)
#endif