4 files changed, 136 insertions, 0 deletions
diff --git a/testsuite/tests/lib/win32/Makefile b/testsuite/tests/lib/win32/Makefile
new file mode 100644
index 0000000000..66afc12be9
--- /dev/null
+++ b/testsuite/tests/lib/win32/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/lib/win32/all.T b/testsuite/tests/lib/win32/all.T
new file mode 100644
index 0000000000..1e9378a5e6
--- /dev/null
+++ b/testsuite/tests/lib/win32/all.T
@@ -0,0 +1,10 @@
+def win_only(opts):
+    if config.platform != "i386-unknown-mingw32" and \
+       config.platform != "i386-unknown-cygwin32":
+	opts.skip = 1
+
+# This isn't a very good test to run automatically at the moment, since
+# it doesn't terminate
+test('win32001', skip, compile_and_run, ['-package lang -package win32'])
+
+test('win32002', win_only, compile_and_run, ['-package Win32'])
diff --git a/testsuite/tests/lib/win32/win32001.hs b/testsuite/tests/lib/win32/win32001.hs
new file mode 100644
index 0000000000..8765dcb0fd
--- /dev/null
+++ b/testsuite/tests/lib/win32/win32001.hs
@@ -0,0 +1,104 @@
+-- Haskell version of "Hello, World" using the Win32 library.
+-- Demonstrates how the Win32 library can be put to use.
+-- (c) sof 1999
+
+
+module Main(main) where
+
+import qualified Win32
+import Addr 
+
+-- Toplevel main just creates a window and pumps messages.
+-- The window procedure (wndProc) we pass in is partially
+-- applied with the user action that takes care of responding
+-- to repaint messages (WM_PAINT).
+
+main :: IO ()
+main = do
+  lpps <- Win32.malloc Win32.sizeofPAINTSTRUCT
+  hwnd <- createWindow 200 200 (wndProc lpps onPaint)
+  messagePump hwnd
+
+-- OnPaint handler for a window - draw a string centred
+-- inside it.
+onPaint :: Win32.RECT -> Win32.HDC -> IO ()
+onPaint (_,_,w,h) hdc = do
+   Win32.setBkMode hdc Win32.tRANSPARENT
+   Win32.setTextColor hdc (Win32.rgb 255 255 0)
+   let y | h==10     = 0
+         | otherwise = ((h-10) `div` 2)
+       x | w==50     = 0
+         | otherwise = (w-50) `div` 2
+   Win32.textOut hdc x y "Hello, world"
+   return ()
+
+-- Simple window procedure - one way to improve and generalise
+-- it would be to pass it a message map (represented as a 
+-- finite map from WindowMessages to actions, perhaps).
+
+wndProc :: Win32.LPPAINTSTRUCT
+	-> (Win32.RECT -> Win32.HDC -> IO ()) -- on paint action
+        -> Win32.HWND
+        -> Win32.WindowMessage
+	-> Win32.WPARAM
+	-> Win32.LPARAM
+	-> IO Win32.LRESULT
+wndProc lpps onPaint hwnd wmsg wParam lParam
+ | wmsg == Win32.wM_DESTROY = do
+     Win32.sendMessage hwnd Win32.wM_QUIT 1 0
+     return 0
+ | wmsg == Win32.wM_PAINT && hwnd /= nullAddr = do
+     r <- Win32.getClientRect hwnd
+     paintWith lpps hwnd (onPaint r)
+     return 0
+ | otherwise = 
+     Win32.defWindowProc (Just hwnd) wmsg wParam lParam
+
+createWindow :: Int -> Int -> Win32.WindowClosure -> IO Win32.HWND
+createWindow width height wndProc = do
+  let winClass = Win32.mkClassName "Hello"
+  icon         <- Win32.loadIcon   Nothing Win32.iDI_APPLICATION
+  cursor       <- Win32.loadCursor Nothing Win32.iDC_ARROW
+  bgBrush      <- Win32.createSolidBrush (Win32.rgb 0 0 255)
+  mainInstance <- Win32.getModuleHandle Nothing
+  Win32.registerClass
+  	  ( Win32.cS_VREDRAW + Win32.cS_HREDRAW
+	  , mainInstance
+	  , Just icon
+	  , Just cursor
+	  , Just bgBrush
+	  , Nothing
+	  , winClass
+	  )
+  w <- Win32.createWindow 
+  		 winClass
+		 "Hello, World example"
+		 Win32.wS_OVERLAPPEDWINDOW
+		 Nothing Nothing -- leave it to the shell to decide the position
+		 		 -- at where to put the window initially
+                 (Just width)
+		 (Just height)
+		 Nothing      -- no parent, i.e, root window is the parent.
+		 Nothing      -- no menu handle
+		 mainInstance
+		 wndProc
+  Win32.showWindow w Win32.sW_SHOWNORMAL
+  Win32.updateWindow w
+  return w
+
+messagePump :: Win32.HWND -> IO ()
+messagePump hwnd = do
+  msg  <- Win32.getMessage (Just hwnd) `catch` \ _ -> return nullAddr
+  if msg == nullAddr then
+    return ()
+   else do
+    Win32.translateMessage msg
+    Win32.dispatchMessage msg
+    messagePump hwnd
+
+paintWith :: Win32.LPPAINTSTRUCT -> Win32.HWND -> (Win32.HDC -> IO a) -> IO a
+paintWith lpps hwnd p = do
+  hdc  <- Win32.beginPaint hwnd lpps
+  a    <- p hdc
+  Win32.endPaint hwnd lpps
+  return a
diff --git a/testsuite/tests/lib/win32/win32002.hs b/testsuite/tests/lib/win32/win32002.hs
new file mode 100644
index 0000000000..0b57985333
--- /dev/null
+++ b/testsuite/tests/lib/win32/win32002.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+-- Test that the Win32 error code from getLastError is thread-local.
+
+import System.Win32
+import Control.Monad
+import Control.Concurrent
+
+main = do
+  setLastError 42
+  r <- getLastError
+  when (r /= 42) $ fail ("wrong: " ++ show r)
+  m <- newEmptyMVar
+  forkIO $ do setLastError 43; putMVar m ()
+  takeMVar m
+  r <- getLastError
+  when (r /= 42) $ fail ("wrong: " ++ show r)
+
+foreign import stdcall unsafe "windows.h SetLastError"
+  setLastError :: ErrCode -> IO ()