{-# LANGUAGE ForeignFunctionInterface #-}
----------------------------------------------------------------------------
-- |
-- Module : Main
-- Copyright : (c) Jan Vornberger 2009
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : jan.vornberger@informatik.uni-oldenburg.de
-- Stability : unstable
-- Portability : not portable
--
-----------------------------------------------------------------------------
module Main where
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Glade
import Control.Concurrent
import Control.Monad(when, forM_)
import qualified Graphics.X11.Xlib as X
import qualified Graphics.X11.Xlib.Extras as XE
import System.Environment
import System.IO
import Data.Char
import Paths_bluetileutils
import Utils
import Data.IORef
import Data.Maybe
import Foreign
import Foreign.C.Types
import Unsafe.Coerce(unsafeCoerce)
foreign import ccall "set_strut_properties"
c_set_strut_properties :: Ptr Window -> CLong -> CLong -> CLong -> CLong
-> CLong -> CLong
-> CLong -> CLong
-> CLong -> CLong
-> CLong -> CLong
-> ()
setStrutProperties :: Window -> (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int) -> IO ()
setStrutProperties gtkWindow (left, right, top, bottom,
left_start_y, left_end_y,
right_start_y, right_end_y,
top_start_x, top_end_x,
bottom_start_x, bottom_end_x) = do
let ptrWin = unsafeCoerce gtkWindow :: ForeignPtr Window
let fi = fromIntegral
withForeignPtr ptrWin $ \realPointer -> do
return $ c_set_strut_properties realPointer (fi left) (fi right) (fi top) (fi bottom)
(fi left_start_y) (fi left_end_y)
(fi right_start_y) (fi right_end_y)
(fi top_start_x) (fi top_end_x)
(fi bottom_start_x) (fi bottom_end_x)
data DockOutput = DO Int String String
| InternalQuitCmd
deriving (Show, Read)
nextScreenCmdOffset :: Int
nextScreenCmdOffset = 18
incMasterCmd :: Int
incMasterCmd = 15
decMasterCmd :: Int
decMasterCmd = 16
quitBluetileCmd :: Int
quitBluetileCmd = 17
quitBluetileStartMetacityCmd :: Int
quitBluetileStartMetacityCmd = 18
-- name of widget caption identifier group command to execute
tbData :: [(String, String, String, String, ToggleButton -> Int -> IORef Bool -> IO ())]
tbData = [ ("togglebutton1" , "1", "1" , "workspace", sendCommandIfToggled 1)
, ("togglebutton2" , "2", "2" , "workspace", sendCommandIfToggled 2)
, ("togglebutton3" , "3", "3" , "workspace", sendCommandIfToggled 3)
, ("togglebutton4" , "4", "4" , "workspace", sendCommandIfToggled 4)
, ("togglebutton5" , "5", "5" , "workspace", sendCommandIfToggled 5)
, ("togglebutton6" , "6", "6" , "workspace", sendCommandIfToggled 6)
, ("togglebutton7" , "7", "7" , "workspace", sendCommandIfToggled 7)
, ("togglebutton8" , "8", "8" , "workspace", sendCommandIfToggled 8)
, ("togglebutton9" , "9", "9" , "workspace", sendCommandIfToggled 9)
, ("togglebutton0" , "0", "0" , "workspace", sendCommandIfToggled 10)
, ("togglebuttonlayouta", "A", "Floating" , "layout" , sendCommandIfToggled 11)
, ("togglebuttonlayoutb", "S", "Tiled1" , "layout" , sendCommandIfToggled 12)
, ("togglebuttonlayoutc", "D", "Tiled2" , "layout" , sendCommandIfToggled 13)
, ("togglebuttonlayoutd", "F", "Fullscreen", "layout" , sendCommandIfToggled 14)
]
main :: IO ()
main = do
args <- getArgs
let myScreenId = if (length args > 0 && head args == "--otherscreen")
then 1
else 0
lockSendCommand <- newIORef False
otherDockProcess <- newIORef Nothing
-- prepare GUI
initGUI
gladeFile <- getDataFileName "bluetiledock.glade"
Just xml <- xmlNew gladeFile
Just dfltScreen <- screenGetDefault
dfltWh <- screenGetWidth dfltScreen
-- monitor0 dock
monitor0Dock <- xmlGetWidget xml castToWindow "monitor0Dock"
windowSetTypeHint monitor0Dock WindowTypeHintDock
onDestroy monitor0Dock mainQuit
(m0DockWh, m0DockHt) <- windowGetSize monitor0Dock
quitBtn <- xmlGetWidget xml castToButton "quitbutton"
let m0DockY = 50
if myScreenId == 0
then do
windowMove monitor0Dock 0 m0DockY
onRealize monitor0Dock $
setStrutProperties monitor0Dock (m0DockWh + 1, 0, 0, 0,
m0DockY, m0DockY + m0DockHt,
0, 0, 0, 0, 0, 0)
return ()
else do
windowMove monitor0Dock (dfltWh - m0DockWh) m0DockY
onRealize monitor0Dock $
setStrutProperties monitor0Dock (0, m0DockWh + 1, 0, 0,
0, 0,
m0DockY, m0DockY + m0DockHt,
0, 0, 0, 0)
widgetSetSensitivity quitBtn False
return ()
widgetShowAll monitor0Dock
-- toggle buttons
forM_ tbData $ \(tbName, tbCaption, _, _, f) -> do
widget <- getTogglebutton xml tbName
buttonSetLabel widget tbCaption
onToggled widget (f widget myScreenId lockSendCommand)
-- master area buttons
incMasterBtn <- xmlGetWidget xml castToButton "incmasterbutton"
decMasterBtn <- xmlGetWidget xml castToButton "decmasterbutton"
onClicked incMasterBtn $ sendCommand incMasterCmd myScreenId
onClicked decMasterBtn $ sendCommand decMasterCmd myScreenId
-- quit button
onClicked quitBtn $ do
dialog <- messageDialogNew (Just monitor0Dock) [DialogModal] MessageQuestion ButtonsNone "Really quit Bluetile?"
dialogAddButton dialog "Quit" (ResponseUser quitBluetileCmd)
dialogAddButton dialog "Quit and start Metacity" (ResponseUser quitBluetileStartMetacityCmd)
dialogAddButton dialog "Cancel" ResponseCancel
resp <- dialogRun dialog
widgetDestroy dialog
case resp of
ResponseUser cmd -> do
sendCommand cmd myScreenId
hndlM <- readIORef otherDockProcess
when (isJust hndlM) $ do
hPutStrLn (fromJust hndlM) $ show InternalQuitCmd
mainQuit
_ -> return ()
-- prepare stdin reader
updates <- getContents
forkIO $ processUpdate (lines updates) xml myScreenId lockSendCommand otherDockProcess
-- enter main GUI loop
timeoutAddFull (yield >> return True) priorityDefaultIdle 50
mainGUI
getTogglebutton :: GladeXML -> String -> IO (ToggleButton)
getTogglebutton xml tbName = xmlGetWidget xml castToToggleButton tbName
processUpdate :: [String] -> GladeXML -> Int -> IORef Bool -> IORef (Maybe Handle) -> IO ()
processUpdate updates xml myScreenId lockSendCommand otherDockProcess =
mapM_ (pU . read) updates
where
pU :: DockOutput -> IO ()
pU update@(DO sid longLayoutDesc cws) = do
let layoutDesc = last $ words longLayoutDesc
hndlM <- readIORef otherDockProcess
when (sid == myScreenId) $ do
writeIORef lockSendCommand True
activateToggleButtons xml cws "workspace"
activateToggleButtons xml layoutDesc "layout"
writeIORef lockSendCommand False
when (sid /= myScreenId && isNothing hndlM) $ do
hndl <- spawnPipe "bluetiledock --otherscreen"
writeIORef otherDockProcess (Just hndl)
hPutStrLn hndl $ show update
when (sid /= myScreenId && isJust hndlM) $ do
hPutStrLn (fromJust hndlM) $ show update
pU InternalQuitCmd = mainQuit
activateToggleButtons :: GladeXML -> String -> String -> IO ()
activateToggleButtons xml cws group = do
let relevantTbData = filter (\(_, _, _, group', _) -> group' == group) tbData
forM_ relevantTbData $ \(tbName, _, tag, _, _) -> do
widget <- getTogglebutton xml tbName
toggleButtonSetActive widget (tag == cws)
sendCommandIfToggled :: (ToggleButtonClass self) => Int -> self -> Int -> IORef Bool -> IO ()
sendCommandIfToggled cmd widget myScreenId lockSendCommand = do
isToggled <- toggleButtonGetActive widget
isLocked <- readIORef lockSendCommand
when (isToggled && not isLocked) $ sendCommand cmd myScreenId
sendCommand :: Int -> Int -> IO ()
sendCommand cmd myScreenId = sendCommandX (cmd + myScreenId * nextScreenCmdOffset)
sendCommandX :: Int -> IO ()
sendCommandX com = do
d <- X.openDisplay ""
rw <- X.rootWindow d $ X.defaultScreen d
a <- X.internAtom d "XMONAD_COMMAND" False
X.allocaXEvent $ \e -> do
XE.setEventType e X.clientMessage
XE.setClientMessageEvent e rw a 32 (fromIntegral com) XE.currentTime
X.sendEvent d rw False X.structureNotifyMask e
X.sync d False