1 files changed, 104 insertions, 0 deletions
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