module GraphicsWindow
	( module GraphicsWindow
	) where

import qualified Xlib as X
import Bits
import Word
import IOExts
import Concurrent( MVar, newMVar, takeMVar, putMVar, readMVar )
import Exception (finally)
import Monad( unless, when )
import Concurrent (forkIO, yield)
import System( getEnv )
import IO( try )
import Maybe
import qualified Graphics_Utilities as Utils
import Graphics_Utilities( modMVar, modMVar_ )
import GraphicsEvent
import qualified GraphicsEvents as E
import GraphicsDC
import qualified GraphicsTimer as T
import GraphicsKey (Key(..))
import NumExts (showHex)

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

type Title = String

runGraphics :: IO () -> IO ()  -- SOE, p48

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 T.Time -> IO Window

closeWindow    :: Window -> IO ()
getWindowRect  :: Window -> IO (Point,Point)
getWindowEvent :: Window -> IO Event
maybeGetWindowEvent :: Window -> IO (Maybe Event)

type Graphic = Draw ()

-- note that modGraphic doesn't force a redraw
setGraphic :: Window -> Graphic -> IO ()
getGraphic :: Window -> IO Graphic
modGraphic :: Window -> (Graphic -> Graphic) -> IO ()
directDraw :: Window -> Graphic -> IO ()

getTime    :: IO T.Time

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

runGraphics m = do
  disp <- try (getEnv "DISPLAY")
  runGraphicsEx (either (const ":0.0") id disp) m

----------------------------------------------------------------
-- 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 ]

getWindowTick :: Window -> IO ()
getWindowTick w = E.getTick (events w)

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

-- This is what we use on Win32
-- type RedrawMode = Graphic -> DrawFun
-- drawGraphic            ::                    RedrawMode
-- drawBufferedGraphic    ::                    RedrawMode
-- drawBufferedGraphicBC  :: Win32.COLORREF  -> RedrawMode

catchErrors :: IO () -> IO ()
catchErrors m = do
  r <- Utils.safeTry m
  case r of
    Left  e -> do
--      putStr "Uncaught Error: "
      print e  
    Right r -> return ()
  return ()

-- On X, we're a bit more abstract
data RedrawMode
  = Unbuffered
  | DoubleBuffered

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

openWindowEx name pos size redrawMode tickRate = do
  display <- getDisplay
  let
    (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
  attributes <- X.allocXSetWindowAttributes
  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
  window <- 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
  X.free 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.a_WM_ICON_NAME 
  X.setTextProperty display window name	X.a_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 depth ref_mbuffer)

  w <- newWindow display window fg_color text_gc pen_gc brush_gc ((x,y),(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 w

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 = do
--   xevent <- X.allocXEvent
--   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
--   X.free xevent               

-- This is the main event loop in the program
main_eloop :: X.Display -> IO ()
main_eloop d = do
  xevent <- X.allocXEvent
  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
  X.free xevent               

-- 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 = do
  xevent <- X.allocXEvent
  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
  X.free xevent               

-- Time in milliseconds
getTime = X.gettimeofday_in_milliseconds

-- 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.Position,X.Position),(X.Dimension,X.Dimension)) -> RedrawStuff -> Maybe T.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     = RGB 255 255 255
    , pen       = defaultPen fg_color
    , 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}
  modMVar wnds (wnd:)
  return wnd

setGraphic w p = do 
  modMVar (graphic w) (const p)
  canDraw <- readIORef (exposed w)
  when canDraw $ do
    mb_dc <- readMVar (ref_dc w)
    case mb_dc of
      Just dc -> drawOnDC dc p (redraw w)
      Nothing -> return ()

getGraphic w = readMVar (graphic w)
modGraphic w = modMVar_ (graphic w)

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

getWindowEvent w = E.getEvent (events w)

maybeGetWindowEvent w
  = do noEvent <- E.isNoEvent(events w)
       if noEvent 
          then return Nothing
          else do ev <- E.getEvent (events w)
                  return (Just ev)

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 = (x,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 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 = (x,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
	      modMVar (ref_rect dc) (const ((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
----------------------------------------------------------------

modIORef :: IORef a -> (a -> a) -> IO ()
modIORef r f = do
  a <- readIORef r
  writeIORef r (f a)

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