Commit 625334c8 authored by rrt's avatar rrt
Browse files

[project @ 2001-10-19 14:03:28 by rrt]

Add win32 hello world as a test. It tests linking stub files, among
other things.
parent 0ac87185
TOP=../../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
-- This isn't a very good test to run automatically at the moment, since
-- it doesn't terminate
include ($confdir ++ "/../vanilla-test.T")
-- Use this itsy helper fn to pass in an extra flag
def myvtr($extra_comp_args, $a, $b)
{
vtr("-package lang -package win32 " ++ $extra_comp_args, $a, $b)
}
-- Only run the tests on Windows
--if $platform == "i386-unknown-mingw32" then
test "win32001" { myvtr("","","") }
--fi
\ No newline at end of file
-- 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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment