module GraphicsWND
	( WND, mkWND, openWND, closeWND, redrawWND
	, handleEvents, closeAllHWNDs
	, wndRect
	, getHWND
	) where

import GraphicsEvent( Event(..) )
import GraphicsEvents( Events, sendEvent, sendTick )
import GraphicsPicture( DrawFun )
import GraphicsTypes
import GraphicsUtilities(safeTry)
import IOExts
import IO(try)
import Monad(liftM2)
import Maybe(isJust)
import Bits

import Win32 hiding ( readFile, writeFile )

----------------------------------------------------------------
-- Once a window has been closed, we want to detect any further
-- operations on the window - so all access is via a mutable Maybe
----------------------------------------------------------------

newtype WND = MkWND (IORef (Maybe HWND))

closeWND :: WND -> IO ()
closeWND wnd@(MkWND hwndref) = do
  mb_hwnd <- readIORef hwndref
  writeIORef hwndref Nothing    -- mark it as closed
  case mb_hwnd of
  Just hwnd -> destroyWindow hwnd
  Nothing   -> return ()

getHWND :: WND -> IO HWND
getHWND (MkWND hwndref) = do
  mb_hwnd <- readIORef hwndref
  case mb_hwnd of 
  Just hwnd -> return hwnd
  Nothing   -> fail (userError "Attempted to act on closed window")

redrawWND :: WND -> IO ()
redrawWND wnd = do
  hwnd <- getHWND wnd
  invalidateRect (Just hwnd) Nothing False

wndRect :: WND -> IO (Point, Point)
wndRect wnd = do
  hwnd <- getHWND wnd
  (l,t,r,b) <- getClientRect hwnd
  return (toPoint (l,t), toPoint (r,b))

mkWND :: HWND -> IO WND
mkWND hwnd = map MkWND (newIORef (Just hwnd))

openWND :: String -> Maybe POINT -> Maybe POINT 
           -> Events      -- where to send the events
           -> DrawFun     -- how to redraw the picture
           -> Maybe MilliSeconds  -- time between timer ticks
           -> IO WND
openWND name pos size events draw tickRate = do
  clAss <- newClass
  hwnd <- createWND name wndProc pos size wS_OVERLAPPEDWINDOW Nothing
  show hwnd False
  updateWindow hwnd
  maybe (return ())
	(\ rate -> setWinTimer hwnd 1 rate >> return ())
	tickRate	
  map MkWND (newIORef (Just hwnd))
 where
  wndProc hwnd msg wParam lParam = do
    -- print msg
    rs <- safeTry $ windowProc 
		      (sendEvent events) 
		      draw
		      (\ wParam -> sendTick events)
		      hwnd msg wParam lParam
    case rs of
    Right a -> return a                   -- ToDo: really ought to force it!
    Left  e -> uncaughtError e >> return 0  -- Let's hope this works ok

  show hwnd iconified = 
    if iconified 
    then do  
      showWindow hwnd sW_SHOWNORMAL -- open "iconified"
      return ()
    else do 
      showWindow hwnd sW_RESTORE    -- open "restored" (ie normal size)
      bringWindowToTop hwnd

-- Note that this code uses a single (static) MSG throughout the whole
-- system - let's hope this isn't a problem
handleEvents :: IO Bool -> IO ()
handleEvents userQuit = do
	      safeTry $
		while (map not (liftM2 (||) userQuit systemQuit)) $ do
		  lpmsg <- getMessage Nothing
		  --getMessage lpmsg Nothing
		  translateMessage lpmsg
		  dispatchMessage lpmsg
	      return ()
 where
  while p s = do { c <- p; if c then s >> while p s else return () }

----------------------------------------------------------------
-- The grotty details - opening WNDs, creating classes, etc
----------------------------------------------------------------

className = mkClassName "GraphicsWND"

newClass :: IO ATOM
newClass = do
  icon         <- loadIcon   Nothing iDI_APPLICATION
  cursor       <- loadCursor Nothing iDC_ARROW
  blackBrush   <- getStockBrush bLACK_BRUSH
  mainInstance <- getModuleHandle Nothing
  atom <- registerClass (
	(cS_HREDRAW .|. cS_VREDRAW), -- redraw if window size Changes
	mainInstance,
	(Just icon),
	(Just cursor),
	(Just blackBrush),
	Nothing,
	className)
  --return atom
  return (maybe undefined id atom)

createWND :: String -> WindowClosure -> Maybe POINT -> Maybe POINT 
		    -> WindowStyle -> Maybe HMENU -> IO HWND
createWND name wndProc posn size style menu = do
  mainInstance <- getModuleHandle Nothing
  mbSize <- calcSize size
  hwnd <- createWindowEx 
	    0 -- Win32.wS_EX_TOPMOST 
	    className
	    name
	    style
	    (map (toInt.fst) posn)   (map (toInt.snd) posn)   -- x y
	    (map (toInt.fst) mbSize) (map (toInt.snd) mbSize) -- w h
	    Nothing                           -- parent
	    menu
	    mainInstance
	    wndProc
  addHWND hwnd
  return hwnd
 where
  calcSize :: Maybe POINT -> IO (Maybe POINT)
  calcSize = 
    maybe (return Nothing)
          (\ (width, height) -> do
             (l,t,r,b) <- adjustWindowRect (0,0,width,height) style (isJust menu)
             return $ Just (r-l, b-t))

windowProc :: (Event -> IO ()) ->   	-- Event Handler
              DrawFun ->		-- Picture redraw
	      (WPARAM -> IO ()) ->	-- tick
	      (HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT)
windowProc send redraw tick hwnd msg wParam lParam
  | msg == wM_PAINT
  = paint
  | msg == wM_MOUSEMOVE
  = mouseMove lParam
  | msg == wM_LBUTTONDOWN || msg == wM_LBUTTONDBLCLK
  = button lParam True True
  | msg == wM_LBUTTONUP
  = button lParam True False
  | msg == wM_RBUTTONDOWN || msg == wM_RBUTTONDBLCLK
  = button lParam False True
  | msg == wM_RBUTTONUP
  = button lParam False False
  | msg == wM_KEYDOWN
  = key wParam True
  | msg == wM_KEYUP
  = key wParam False
  | msg == wM_TIMER
  = timer wParam
  | msg == wM_SIZE
  = resize
{-
  | msg == wM_MOUSEACTIVATE
  = do
      hwnd' <- setFocus hwnd
      if hwnd `eqHWND` hwnd' 
        then
          return mA_NOACTIVATE  -- already had input focus
        else
          return mA_ACTIVATEANDEAT
-}
  | msg == wM_DESTROY
  = destroy
  | otherwise
  = defWindowProc (Just hwnd) msg wParam lParam

 where
  paint :: IO LRESULT
  paint = paintWith hwnd (\hdc lpps -> do
	redraw hwnd hdc
	return 0
	)

  button :: LPARAM -> Bool -> Bool -> IO LRESULT
  button lParam isLeft isDown = do
	let (y,x) = lParam `divMod` 65536
	send (Button {pt = toPoint (x,y), isLeft, isDown})
	return 0

  key :: WPARAM -> Bool -> IO LRESULT
  key wParam isDown = do
     	send (Key { char = toEnum (toInt wParam), isDown })
--     	send (Key { char = toEnum wParam, isDown })
	return 0

  mouseMove :: LPARAM -> IO LRESULT
  mouseMove lParam = do
	let (y,x) = lParam `divMod` 65536
	send (MouseMove { pt = toPoint (x,y) })
	return 0

  timer :: WPARAM -> IO LRESULT
  timer wParam = do
	tick wParam
	return 0

  resize :: IO LRESULT
  resize = do
	-- don't send new size, it may be out of date by the time we
	-- get round to reading the event
	send Resize
	return 0

  destroy :: IO LRESULT
  destroy = do
        removeHWND hwnd
        send Closed
	return 0

paintWith :: HWND -> (HDC -> LPPAINTSTRUCT -> IO a) -> IO a
paintWith hwnd p = do
  lpps <- malloc sizeofPAINTSTRUCT
  hdc  <- beginPaint hwnd lpps
  a    <- p hdc lpps
  endPaint hwnd lpps
  free lpps 
  return a

----------------------------------------------------------------
-- The open window list
----------------------------------------------------------------

-- It's very important that we close any windows - even if the 
-- Haskell application fails to do so (or aborts for some reason).
-- Therefore we keep a list of open windows and close them all at the
-- end.

-- persistent list of open windows
windows :: IORef [HWND]
windows = unsafePerformIO (newIORef [])

noMoreWindows :: IO Bool
noMoreWindows = map null (readIORef windows)

-- It's also important that we abort cleanly if an uncaught IOError
-- occurs - this flag keeps track of such things

hadUncaughtError :: IORef Bool
hadUncaughtError = unsafePerformIO (newIORef False)

-- We call this if an uncaught error has occured
uncaughtError :: IOError -> IO ()
uncaughtError e = do
  putStr "Uncaught Error: "
  print e  
  writeIORef hadUncaughtError True

systemQuit :: IO Bool
systemQuit = liftM2 (||) (readIORef hadUncaughtError) noMoreWindows

closeAllHWNDs :: IO ()
closeAllHWNDs = do
  hwnds <- readIORef windows
  mapM_ destroyWindow hwnds
  writeIORef windows []
  writeIORef hadUncaughtError False -- clear the system


addHWND :: HWND -> IO ()
addHWND hwnd = do
  hwnds <- readIORef windows
  writeIORef windows (hwnd:hwnds)

-- remove a HWND from windows list
removeHWND :: HWND -> IO ()
removeHWND hwnd = do
  hwnds <- readIORef windows
  writeIORef windows (filter (/= hwnd) hwnds)