Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Copy tests from GHC testsuite; part of #1161

  • Loading branch information...
commit 0d5870481cbc15bd4079d9b609d060ab077b9a4a 1 parent e5f27f2
@pcapriotti pcapriotti authored
Showing with 129 additions and 0 deletions.
  1. +6 −0 tests/all.T
  2. +104 −0 tests/helloworld.hs
  3. +19 −0 tests/lasterror.hs
View
6 tests/all.T
@@ -1 +1,7 @@
test('registry001', normal, compile_and_run, [''])
+
+# This isn't a very good test to run automatically at the moment, since
+# it doesn't terminate
+test('helloworld', skip, compile_and_run, ['-package lang -package win32'])
+
+test('lasterror', normal, compile_and_run, ['-package Win32'])
View
104 tests/helloworld.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
View
19 tests/lasterror.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 ()
Please sign in to comment.
Something went wrong with that request. Please try again.