Repository : ssh://darcs.haskell.org//srv/darcs/packages/Win32 On branch : master
http://hackage.haskell.org/trac/ghc/changeset/0d5870481cbc15bd4079d9b609d060ab077b9a4a >--------------------------------------------------------------- commit 0d5870481cbc15bd4079d9b609d060ab077b9a4a Author: Paolo Capriotti <[email protected]> Date: Fri Mar 9 11:45:05 2012 +0000 Copy tests from GHC testsuite; part of #1161 >--------------------------------------------------------------- tests/all.T | 6 +++ tests/helloworld.hs | 104 +++++++++++++++++++++++++++++++++++++++++++++++++++ tests/lasterror.hs | 19 +++++++++ 3 files changed, 129 insertions(+), 0 deletions(-) diff --git a/tests/all.T b/tests/all.T index 42bbbde..589004c 100644 --- a/tests/all.T +++ b/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']) diff --git a/tests/helloworld.hs b/tests/helloworld.hs new file mode 100644 index 0000000..8765dcb --- /dev/null +++ b/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 diff --git a/tests/lasterror.hs b/tests/lasterror.hs new file mode 100644 index 0000000..0b57985 --- /dev/null +++ b/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 () _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
