    {-# LANGUAGE ForeignFunctionInterface #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Graphics.HGL.X11.Window
    -- Copyright   :  (c) Alastair Reid, 1999-2003
    -- License     :  BSD-style (see the file libraries/base/LICENSE)
    --
    -- Maintainer  :  libraries@haskell.org
    -- Stability   :  internal
    -- Portability :  non-portable (requires concurrency)
    --
    -- A simple graphics library.
    --
    -----------------------------------------------------------------------------

    -- #hide
    module Graphics.HGL.X11.Window
    	( runGraphicsEx		-- :: String -> IO () -> IO ()

    	, Window(events, graphic)
    	, 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 ()

    	, 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)

    ----------------------------------------------------------------
    -- Interface
    ----------------------------------------------------------------

    data Window = MkWindow
      { wnd     :: X.Window	         -- the real window
      , ref_dc  :: MVar (Maybe DC)   -- "device context"
      , exposed :: IORef Bool        -- have we had an expose event yet?
      , events  :: E.Events          -- the event stream
      , graphic :: MVar Graphic      -- the current 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 ()

    ----------------------------------------------------------------
    -- Implementation
    ----------------------------------------------------------------

    ----------------------------------------------------------------
    -- Windows
    ----------------------------------------------------------------

    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 -- mark it for dead
         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)  -- ths dc had better hold a window!
           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 -- bring out your dead

    sendTicks :: IO ()
    sendTicks = do
      ws <- readMVar wnds
      sequence_ [ E.sendTick (events w) | w <- ws ]

    -- persistent list of open windows
    wnds :: MVar [Window]
    wnds = unsafePerformIO (newMVar [])

    -- persistent list of timers
    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
    --  color_map <- X.getStandardColormap display root X.a_RGB_BEST_MAP
      -- HN 2001-01-30
      -- There is a race condition here since the event loop terminates if it
      -- encounters an empty window list (in the global, imperative, variable
      -- wnds). Thus, if m has not yet opened a window (assuming it will!)
      -- when the event_loop is entered, it will exit immediately.
      -- Solution: wait until either the window list is non-empty, or until
      -- m exits (in case it does not open a window for some reason).
      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
    --  X.sync display True
      closeAllWindows
    --  X.sync display True
      -- A final yield to make sure there's no threads thinking of
      -- accessing the display
      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
    --      putStr "Uncaught Error: "
          print e
        Right _ -> return ()
      return ()

    ----------------------------------------------------------------
    -- Implementation
    ----------------------------------------------------------------

    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

      -- ToDo: resurrect the old code for constructing attribute sets
      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
        -- We use backing store to reduce the number of expose events due to
        -- raising/lowering windows.
        X.set_backing_store attributes X.whenMapped
        -- We use bit-gravity to avoid generating exposure events when a window is
        -- made smaller (they can't be avoided when the window is enlarged).
        -- The choice of NW is somewhat arbitrary but hopefully works often
        -- enough to be worth it.
        X.set_bit_gravity attributes X.northWestGravity
        let attrmask
              =   X.cWBackPixel
              .|. X.cWEventMask
              .|. X.cWBackingStore
              .|. X.cWBitGravity
        X.createWindow display root
    	 x y -- x, y
    	 w h -- width, height
    	 1   -- border_width
    	 depth          -- use CopyFromParent??
    	 X.inputOutput
    	 visual         -- use CopyFromParent??
    	 attrmask
    	 attributes

      -- AC, 1/9/2000: Tell the window manager that we want to use the
      -- DELETE_WINDOW protocol
      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 -- gc for clearing the screen
          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

      -- It might be some time till we get back to the event loop
      -- so we try to process as many events as possible now.
      -- This is a bit of a hack and partly aimed at avoiding the bug that
      -- directDraw might try to draw something before the first expose event
      -- is processed.
      -- To make the hack even more effective, we wait a short time (allegedly
      -- 1uS) and synchronise before looking for the event.
      --
      -- NB:
      -- This whole thing is based on the implicit notion that the server thread
      -- is "lower priority" than the user threads.  That is, the server thread
      -- will only run when no user threads are runnable.
      --
      -- Or, more concretely, only the server thread calls yield so it's safe
      -- to call the minor_eloop (which doesn't yield or block) but not the
      -- major_eloop because, amongst other things, it may yield or block.
      X.waitForEvent display 1
      X.sync display False
      minor_eloop display

      return win

    closeWindow w = do
      closeWindow' True w
      removeDeadWindows      -- bring out your dead

    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)) -- ToDo?

    -- main_eloop :: X.Display -> IO ()
    -- main_eloop d =
    --   X.allocaXEvent $ \ xevent -> do
    --   let loop = do
    -- --    X.sync d False -- wild attempt to fix the broken X connection problem
    --     count <- X.pending d
    --     if (count > 0) then do
    -- --      X.sync d False -- wild attempt to fix the broken X connection problem
    -- 	 X.nextEvent d xevent
    -- 	 window <- X.get_Window xevent
    -- 	 wnd <- findWindow window
    -- 	 etype <- X.get_EventType xevent
    -- --      print (window,etype)
    -- 	 dispatchEvent wnd etype xevent
    -- 	 ws <- readMVar wnds
    -- 	 unless (null ws) loop
    -- 	else
    -- 	 loop
    --   loop

    -- This is the main event loop in the program
    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
             -- Event in queue or no tick pending.
    	 X.nextEvent d xevent
    	 window <- X.get_Window xevent
    	 etype  <- X.get_EventType xevent
    	 -- showEvent etype
    	 withWindow window $ \ wnd -> do
    	   dispatchEvent d wnd etype xevent
    	else do
    	 -- No event and tick pending.
    	 let delay = fromJust next
    	 t0 <- getTime
    	 timedOut <- X.waitForEvent d (fromIntegral (delay * 1000))
    	 t1 <- getTime
    	 T.fireTimers timers (t1 - t0)
      let
        loop = do
          -- We yield at this point because we're (potentially)
          -- about to block so we should give other threads a chance
          -- to run.
          yield
          ws <- readMVar wnds
          if (null ws)
            then return ()
            else do
              handleEvent
              loop
      loop

    -- This event loop is the same as above except that it is
    -- non-blocking: it only handles those events that have already arrived.
    -- And this is important because it means we don't have to yield which
    -- means it can safely be called by user code (see comment in openWindowEx).
    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
      --       print etype
          withWindow window $ \ wnd -> do
            dispatchEvent d wnd etype xevent
          return ()

        loop = do
          ws <- readMVar wnds
          if null ws
            then
              return ()
            else do
              -- Note: _do not_ call pending if null ws
              count <- X.pending d
              if count == 0
                then return ()
                else do
                  handleEvent
                  loop
      loop

    -- The DC is wrapped inside (MVar (Maybe ...)) so that we can mark
    -- windows as being dead the moment they die and so that we don't
    -- try to keep writing to them afterwards.
    -- The events remain valid after the window dies.
    -- It might be wiser to clear all events(???) and start returning
    -- Closed whenever events are read - or (more GC friendly?), when
    -- first read occurs but block thereafter?

    data RedrawStuff
      = UnbufferedStuff
      | BufferedStuff
          X.GC 			-- GC with foreground = background_color
          Int  			-- depth
          (IORef (Maybe X.Pixmap))	-- The buffer, allocated on demand
    				-- drawBuffered.

    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 ())
    -- failed attempts to find the default font
    --  f'  <- X.fontFromGC display tgc
    --  f   <- X.queryFont display f'
    -- Since we can't ask the server what default font it chooses to bless
    -- us with, we have to set an explicit font.
      f   <- X.loadQueryFont display "9x15"  -- a random choice
      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 ])  -- ToDo: don't use head

    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
      -- AC, 1/9/2000: treat a ClientMesage as a destroy event
      -- TODO: really need to examine the event in more detail,
      -- and ensure that xevent.xclient.message_type==ATOM_WM_PROTOCOLS &&
      --  xevent.xclient.data.l[0]==ATOM_WM_DELETE_WINDOW
      -- where ATOM_XXX is obtained from XInternAtom(dpy,"XXX",False)
      | etype == X.clientMessage
      = destroy

      -- ToDo: consider printing a warning message
      | otherwise
      = return ()

     where

      -- Redrawing is awkward because the request comes as a number of
      -- separate events.  We need to do one of the following (we currently
      -- do a combination of (1) and (3)):
      -- 1) Do a single redraw of the entire window but first delete all other
      --    expose events for this window from the queue.
      -- 2) Use all expose events for this window to build a Region object
      --    and use that to optimise redraws.
      -- 3) When double-buffering, use the buffer and information about
      --    whether it is up to date to serve redraws from the buffer.
      --    When single-buffering, use the server's backing store to reduce
      --    the number of expose events.  (Combine with bit-gravity info to
      --    handle resize requests.)
      paint :: IO ()
      paint = do
        let
          stompOnExposeEvents = do
    --        X.get_ExposeEvent xevent >>= print
            gotOne <- X.checkTypedWindowEvent display (wnd w) X.expose xevent
            when gotOne stompOnExposeEvents
        writeIORef (exposed w) True  -- now safe to draw directly
        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 -- assume that button 1 = left button
        send w Button{pt = (fromIntegral x, fromIntegral y), isLeft=isLeft, isDown=isDown}

    -- An X KeySym is *not* a character; not even a Unicode character! And
    -- since characters in Hugs only are 8-bit, we get a runtime error
    -- below. There is an underlying assumption that key events only
    -- involve characters. But of course there are function keys, arrow
    -- keys, etc. too. While this will be a problem if one wants to get at
    -- e.g. arrow keys (e.g. for some drawing application) or at
    -- dead/multi-keys for doing proper input, we'll ignore them
    -- completely for now. Furthermore, one really needs to call
    -- XlookupString (not XkeysymToString!) to do the processing! We'll
    -- ignore that too, and do a static mapping of just a few keysyms.

      key :: Bool -> IO ()
      key isDown =
        do
          -- Should really use XmbLookupString here to make compose work.
          -- It's OK to call X.lookupString both on key up and down events.
          -- Not true for X.mbLookupString. In that case, use e.g. X.lookup
          -- on key up events.
          (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 ()

    	-- don't send new size, it may be out of date by the time we
    	-- get round to reading the event
    	send w Resize

      destroy :: IO ()
      destroy = do
    	-- putStrLn "Window Destroyed" -- todo
            closeWindow' True w
            removeDeadWindows     -- bring out your dead
            send w Closed

    ----------------------------------------------------------------
    -- Utilities
    ----------------------------------------------------------------

    -- Only for debugging

    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)

    ----------------------------------------------------------------
    -- End
    ----------------------------------------------------------------