module Graphics.HGL.X11.Window
( runGraphicsEx
, Window(events, graphic)
, openWindowEx
, closeWindow
, getWindowRect
, redrawWindow
, directDraw
, sendTicks, findWindow, showEvent
) where
import Graphics.HGL.Internals.Types
import Graphics.HGL.Internals.Draw (Graphic, Draw, unDraw)
import Graphics.HGL.Internals.Event
import qualified Graphics.HGL.Internals.Utilities as Utils
import qualified Graphics.HGL.Internals.Events as E
import Graphics.HGL.X11.Types
import Graphics.HGL.X11.Display
import Graphics.HGL.X11.DC
import qualified Graphics.HGL.X11.Timer as T
import qualified Graphics.X11.Xlib as X
import Control.Concurrent (forkIO, yield)
import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, readMVar)
import Control.Exception (finally)
import Control.Monad (when)
import Data.Bits
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe (isJust, fromJust, fromMaybe)
import System.IO.Unsafe (unsafePerformIO)
data Window = MkWindow
{ wnd :: X.Window
, ref_dc :: MVar (Maybe DC)
, exposed :: IORef Bool
, events :: E.Events
, graphic :: MVar Graphic
, redraw :: RedrawStuff
, timer :: Maybe T.Timer
}
openWindowEx :: Title -> Maybe Point -> Size ->
RedrawMode -> Maybe Time -> IO Window
closeWindow :: Window -> IO ()
getWindowRect :: Window -> IO (Point,Point)
redrawWindow :: Window -> IO ()
directDraw :: Window -> Graphic -> IO ()
closeWindow' :: Bool -> Window -> IO ()
closeWindow' destroyXWindow w = do
mb_dc <- takeMVar (ref_dc w)
case mb_dc of
Just dc -> do
putMVar (ref_dc w) Nothing
X.freeGC (disp dc) (textGC dc)
X.freeGC (disp dc) (paintGC dc)
X.freeGC (disp dc) (brushGC dc)
case (redraw w) of
UnbufferedStuff -> return ()
BufferedStuff gc _ ref_mbuffer -> do
X.freeGC (disp dc) gc
removeBuffer dc ref_mbuffer
when destroyXWindow $ do
X.destroyWindow (disp dc) (drawable dc)
minor_eloop (disp dc)
Nothing -> do
putMVar (ref_dc w) Nothing
removeBuffer :: DC -> IORef (Maybe X.Pixmap) -> IO ()
removeBuffer dc ref_mbuffer = do
mbuffer <- readIORef ref_mbuffer
case mbuffer of
Nothing -> return ()
Just buffer -> X.freePixmap (disp dc) buffer
writeIORef ref_mbuffer Nothing
removeDeadWindows :: IO ()
removeDeadWindows = do
ws <- takeMVar wnds
ws' <- remove ws []
putMVar wnds ws'
where
remove [] r = return r
remove (w:ws) r = do
mb_dc <- readMVar (ref_dc w)
if (isJust mb_dc)
then remove ws (w:r)
else remove ws r
closeAllWindows :: IO ()
closeAllWindows = do
ws <- readMVar wnds
mapM_ (closeWindow' True) ws
removeDeadWindows
sendTicks :: IO ()
sendTicks = do
ws <- readMVar wnds
sequence_ [ E.sendTick (events w) | w <- ws ]
wnds :: MVar [Window]
wnds = unsafePerformIO (newMVar [])
timers :: T.Timers
timers = unsafePerformIO T.newTimers
runGraphicsEx :: String -> IO () -> IO ()
runGraphicsEx host m = do
when threaded $ do X.initThreads; return ()
X.setDefaultErrorHandler
display <- openDisplay host closeAllWindows
T.clearTimers timers
mDone <- newIORef False
forkIO (catchErrors m `finally` writeIORef mDone True)
let loop = do
yield
ws <- readMVar wnds
d <- readIORef mDone
if not (null ws) then
main_eloop display
else if not d then
loop
else
return ()
catchErrors loop
closeAllWindows
yield
closeDisplay
#ifdef __GLASGOW_HASKELL__
foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
#else
threaded = False
#endif
catchErrors :: IO () -> IO ()
catchErrors m = do
r <- Utils.safeTry m
case r of
Left e -> do
print e
Right _ -> return ()
return ()
openWindowEx name pos size redrawMode tickRate = do
display <- getDisplay
let
corner@(X.Point x y) = fromPoint (fromMaybe (0,0) pos)
(w,h) = fromSize size
let screen = X.defaultScreenOfDisplay display
fg_color = X.whitePixelOfScreen screen
bg_color = X.blackPixelOfScreen screen
depth = X.defaultDepthOfScreen screen
root = X.rootWindowOfScreen screen
visual = X.defaultVisualOfScreen screen
window <- X.allocaSetWindowAttributes $ \ attributes -> do
X.set_background_pixel attributes bg_color
let event_mask =
( X.buttonPressMask
.|. X.buttonReleaseMask
.|. X.keyPressMask
.|. X.keyReleaseMask
.|. X.pointerMotionMask
.|. X.exposureMask
.|. X.structureNotifyMask
)
X.set_event_mask attributes event_mask
X.set_backing_store attributes X.whenMapped
X.set_bit_gravity attributes X.northWestGravity
let attrmask
= X.cWBackPixel
.|. X.cWEventMask
.|. X.cWBackingStore
.|. X.cWBitGravity
X.createWindow display root
x y
w h
1
depth
X.inputOutput
visual
attrmask
attributes
delWinAtom <- X.internAtom display "WM_DELETE_WINDOW" False
X.setWMProtocols display window [delWinAtom]
X.setTextProperty display window name X.wM_ICON_NAME
X.setTextProperty display window name X.wM_NAME
X.mapWindow display window
X.raiseWindow display window
text_gc <- X.createGC display window
X.setBackground display text_gc bg_color
X.setForeground display text_gc fg_color
pen_gc <- X.createGC display window
X.setBackground display pen_gc bg_color
X.setForeground display pen_gc fg_color
brush_gc <- X.createGC display window
X.setBackground display brush_gc bg_color
X.setForeground display brush_gc fg_color
redraw <- case redrawMode of
Unbuffered -> return UnbufferedStuff
DoubleBuffered -> do
gc <- X.createGC display window
X.setForeground display gc bg_color
ref_mbuffer <- newIORef Nothing
return (BufferedStuff gc (fromIntegral depth) ref_mbuffer)
win <- newWindow display window fg_color text_gc pen_gc brush_gc (corner,(w,h)) redraw tickRate
X.waitForEvent display 1
X.sync display False
minor_eloop display
return win
closeWindow w = do
closeWindow' True w
removeDeadWindows
getWindowRect w = do
mb_dc <- readMVar (ref_dc w)
case mb_dc of
Just dc -> do
(pt,sz) <- readMVar (ref_rect dc)
return (toPoint pt, toSize sz)
Nothing ->
return ((0,0),(0,0))
main_eloop :: X.Display -> IO ()
main_eloop d =
X.allocaXEvent $ \ xevent -> do
let handleEvent = do
count <- X.pending d
next <- T.nextTick timers
if (count > 0 || not (isJust next))
then do
X.nextEvent d xevent
window <- X.get_Window xevent
etype <- X.get_EventType xevent
withWindow window $ \ wnd -> do
dispatchEvent d wnd etype xevent
else do
let delay = fromJust next
t0 <- getTime
timedOut <- X.waitForEvent d (fromIntegral (delay * 1000))
t1 <- getTime
T.fireTimers timers (t1 t0)
let
loop = do
yield
ws <- readMVar wnds
if (null ws)
then return ()
else do
handleEvent
loop
loop
minor_eloop :: X.Display -> IO ()
minor_eloop d =
X.allocaXEvent $ \ xevent -> do
let
handleEvent = do
X.nextEvent d xevent
window <- X.get_Window xevent
etype <- X.get_EventType xevent
withWindow window $ \ wnd -> do
dispatchEvent d wnd etype xevent
return ()
loop = do
ws <- readMVar wnds
if null ws
then
return ()
else do
count <- X.pending d
if count == 0
then return ()
else do
handleEvent
loop
loop
data RedrawStuff
= UnbufferedStuff
| BufferedStuff
X.GC
Int
(IORef (Maybe X.Pixmap))
drawOnDC :: DC -> Draw () -> RedrawStuff -> IO ()
drawOnDC dc p redraw =
case redraw of
UnbufferedStuff -> drawUnbuffered dc p
BufferedStuff gc depth ref_mbuffer -> drawBuffered dc p gc depth ref_mbuffer
newWindow :: X.Display -> X.Window -> X.Pixel -> X.GC -> X.GC -> X.GC -> (X.Point,(X.Dimension,X.Dimension)) -> RedrawStuff -> Maybe Time -> IO Window
newWindow display window fg_color tgc pgc bgc rect redraw tickRate = do
es <- E.newEvents
pic <- newMVar (return ())
f <- X.loadQueryFont display "9x15"
X.setFont display tgc (X.fontFromFontStruct f)
bits <- newMVar DC_Bits
{ textColor = RGB 255 255 255
, bkColor = RGB 0 0 0
, bkMode = Transparent
, textAlignment = (Left',Top)
, brush = Brush (RGB 255 255 255)
, pen = defaultPen fg_color
, font = Font f
}
ref_rect <- newMVar rect
dc <- newMVar (Just MkDC{disp=display,drawable=window,textGC=tgc,paintGC=pgc,brushGC=bgc,ref_rect=ref_rect,ref_bits=bits})
timer <- case tickRate of
Just t -> T.new timers t (E.sendTick es) >>= return.Just
Nothing -> return Nothing
ref_exposed <- newIORef False
let wnd = MkWindow{wnd=window,ref_dc=dc,exposed=ref_exposed,events=es,graphic=pic,redraw=redraw,timer=timer}
Utils.modMVar wnds (wnd:)
return wnd
redrawWindow w = do
canDraw <- readIORef (exposed w)
when canDraw $ do
mb_dc <- readMVar (ref_dc w)
case mb_dc of
Just dc -> do
p <- readMVar (graphic w)
drawOnDC dc p (redraw w)
Nothing -> return ()
directDraw w p = do
mb_dc <- readMVar (ref_dc w)
canDraw <- readIORef (exposed w)
when canDraw $ do
case mb_dc of
Just dc -> unDraw p dc
Nothing -> return ()
findWindow :: X.Window -> IO Window
findWindow xw = do
ws <- readMVar wnds
return (head [ w | w <- ws, xw == wnd w ])
withWindow :: X.Window -> (Window -> IO ()) -> IO ()
withWindow xw k = do
ws <- readMVar wnds
case [ w | w <- ws, xw == wnd w ] of
(w:_) -> k w
_ -> return ()
send :: Window -> Event -> IO ()
send w e = E.sendEvent (events w) e
dispatchEvent :: X.Display -> Window -> X.EventType -> X.XEventPtr -> IO ()
dispatchEvent display w etype xevent
| etype == X.graphicsExpose || etype == X.expose
= paint
| etype == X.motionNotify
= mouseMove
| etype == X.buttonPress
= button True
| etype == X.buttonRelease
= button False
| etype == X.keyPress
= key True
| etype == X.keyRelease
= key False
| etype == X.configureNotify
= reconfig
| etype == X.destroyNotify
= destroy
| etype == X.clientMessage
= destroy
| otherwise
= return ()
where
paint :: IO ()
paint = do
let
stompOnExposeEvents = do
gotOne <- X.checkTypedWindowEvent display (wnd w) X.expose xevent
when gotOne stompOnExposeEvents
writeIORef (exposed w) True
stompOnExposeEvents
p <- readMVar (graphic w)
mb_dc <- readMVar (ref_dc w)
case mb_dc of
Just dc -> drawOnDC dc p (redraw w)
Nothing -> return ()
button :: Bool -> IO ()
button isDown = do
(_,_,_,x,y,_,_,_,b,_) <- X.get_ButtonEvent xevent
let isLeft = b == 1
send w Button{pt = (fromIntegral x, fromIntegral y), isLeft=isLeft, isDown=isDown}
key :: Bool -> IO ()
key isDown =
do
(mks, s) <- X.lookupString (X.asKeyEvent xevent)
case mks of
Just ks -> send w (Key {keysym = MkKey ks, isDown = isDown})
Nothing -> return ()
if isDown then (mapM_ (\c -> send w (Char {char = c})) s) else return ()
mouseMove ::IO ()
mouseMove = do
(_,_,_,x,y,_,_,_,_,_) <- X.get_MotionEvent xevent
send w MouseMove{ pt = (fromIntegral x, fromIntegral y) }
reconfig :: IO ()
reconfig = do
(x,y,width,height) <- X.get_ConfigureEvent xevent
mb_dc <- readMVar (ref_dc w)
case mb_dc of
Just dc -> do
Utils.modMVar (ref_rect dc) (const ((X.Point x y),(width,height)))
case (redraw w) of
UnbufferedStuff -> return ()
BufferedStuff _ _ ref_mbuffer -> removeBuffer dc ref_mbuffer
Nothing -> return ()
send w Resize
destroy :: IO ()
destroy = do
closeWindow' True w
removeDeadWindows
send w Closed
showEvent :: X.EventType -> IO ()
showEvent etype
| etype == X.keyPress
= putStrLn "keyPress"
| etype == X.keyRelease
= putStrLn "keyRelease"
| etype == X.buttonPress
= putStrLn "buttonPress"
| etype == X.buttonRelease
= putStrLn "buttonRelease"
| etype == X.motionNotify
= putStrLn "motionNotify"
| etype == X.enterNotify
= putStrLn "enterNotify"
| etype == X.leaveNotify
= putStrLn "leaveNotify"
| etype == X.focusIn
= putStrLn "focusIn"
| etype == X.focusOut
= putStrLn "focusOut"
| etype == X.keymapNotify
= putStrLn "keymapNotify"
| etype == X.expose
= putStrLn "expose"
| etype == X.graphicsExpose
= putStrLn "graphicsExpose"
| etype == X.noExpose
= putStrLn "noExpose"
| etype == X.visibilityNotify
= putStrLn "visibilityNotify"
| etype == X.createNotify
= putStrLn "createNotify"
| etype == X.destroyNotify
= putStrLn "destroyNotify"
| etype == X.unmapNotify
= putStrLn "unmapNotify"
| etype == X.mapNotify
= putStrLn "mapNotify"
| etype == X.mapRequest
= putStrLn "mapRequest"
| etype == X.reparentNotify
= putStrLn "reparentNotify"
| etype == X.configureNotify
= putStrLn "configureNotify"
| etype == X.configureRequest
= putStrLn "configureRequest"
| etype == X.gravityNotify
= putStrLn "gravityNotify"
| etype == X.resizeRequest
= putStrLn "resizeRequest"
| etype == X.circulateNotify
= putStrLn "circulateNotify"
| etype == X.circulateRequest
= putStrLn "circulateRequest"
| etype == X.propertyNotify
= putStrLn "propertyNotify"
| etype == X.selectionClear
= putStrLn "selectionClear"
| etype == X.selectionRequest
= putStrLn "selectionRequest"
| etype == X.selectionNotify
= putStrLn "selectionNotify"
| etype == X.colormapNotify
= putStrLn "colormapNotify"
| etype == X.clientMessage
= putStrLn "clientMessage"
| etype == X.mappingNotify
= putStrLn "mappingNotify"
| etype == X.lASTEvent
= putStrLn "lASTEvent"
| otherwise
= putStrLn ("Unknown X event type: " ++ show etype)