← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to libraries/Win32/examples/hello.lhs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
libraries/Win32/examples/hello.lhs
 
1
%
 
2
% (c) sof, 1999
 
3
%
 
4
 
 
5
Haskell version of "Hello, World" using the Win32 library.
 
6
Demonstrates how the Win32 library can be put to use.
 
7
 
 
8
Works with Hugs and GHC. To compile it up using the latter,
 
9
do: "ghc -o main hello.lhs -syslib win32 -fglasgow-exts"
 
10
 
 
11
For GHC 5.03:
 
12
 
 
13
  ghc -package win32 hello.lhs -o hello.exe -optl "-Wl,--subsystem,windows"
 
14
 
 
15
\begin{code}
 
16
module Main(main) where
 
17
 
 
18
import qualified Graphics.Win32
 
19
import qualified System.Win32.DLL
 
20
import qualified System.Win32.Types
 
21
import Control.Exception (bracket)
 
22
import Foreign
 
23
import System.Exit
 
24
{-import Addr-}
 
25
\end{code}
 
26
 
 
27
Toplevel main just creates a window and pumps messages.
 
28
The window procedure (wndProc) we pass in is partially
 
29
applied with the user action that takes care of responding
 
30
to repaint messages (WM_PAINT).
 
31
 
 
32
\begin{code}
 
33
main :: IO ()
 
34
main =
 
35
  Graphics.Win32.allocaPAINTSTRUCT $ \ lpps -> do
 
36
  hwnd <- createWindow 200 200 (wndProc lpps onPaint)
 
37
  messagePump hwnd
 
38
 
 
39
{-
 
40
 OnPaint handler for a window - draw a string centred
 
41
 inside it.
 
42
-}
 
43
onPaint :: Graphics.Win32.RECT -> Graphics.Win32.HDC -> IO ()
 
44
onPaint (_,_,w,h) hdc = do
 
45
   Graphics.Win32.setBkMode hdc Graphics.Win32.tRANSPARENT
 
46
   Graphics.Win32.setTextColor hdc (Graphics.Win32.rgb 255 255 0)
 
47
   let y | h==10     = 0
 
48
         | otherwise = ((h-10) `div` 2)
 
49
       x | w==50     = 0
 
50
         | otherwise = (w-50) `div` 2
 
51
   Graphics.Win32.textOut hdc x y "Hello, world"
 
52
   return ()
 
53
\end{code}
 
54
 
 
55
Simple window procedure - one way to improve and generalise
 
56
it would be to pass it a message map (represented as a
 
57
finite map from WindowMessages to actions, perhaps).
 
58
 
 
59
\begin{code}
 
60
 
 
61
wndProc :: Graphics.Win32.LPPAINTSTRUCT
 
62
        -> (Graphics.Win32.RECT -> Graphics.Win32.HDC -> IO ()) -- on paint action
 
63
        -> Graphics.Win32.HWND
 
64
        -> Graphics.Win32.WindowMessage
 
65
        -> Graphics.Win32.WPARAM
 
66
        -> Graphics.Win32.LPARAM
 
67
        -> IO Graphics.Win32.LRESULT
 
68
wndProc lpps onPaint hwnd wmsg wParam lParam
 
69
 | wmsg == Graphics.Win32.wM_DESTROY = do
 
70
     Graphics.Win32.sendMessage hwnd Graphics.Win32.wM_QUIT 1 0
 
71
     return 0
 
72
 | wmsg == Graphics.Win32.wM_PAINT && hwnd /= nullPtr = do
 
73
     r <- Graphics.Win32.getClientRect hwnd
 
74
     paintWith lpps hwnd (onPaint r)
 
75
     return 0
 
76
 | otherwise =
 
77
     Graphics.Win32.defWindowProc (Just hwnd) wmsg wParam lParam
 
78
 
 
79
createWindow :: Int -> Int -> Graphics.Win32.WindowClosure -> IO Graphics.Win32.HWND
 
80
createWindow width height wndProc = do
 
81
  let winClass = Graphics.Win32.mkClassName "Hello"
 
82
  icon         <- Graphics.Win32.loadIcon   Nothing Graphics.Win32.iDI_APPLICATION
 
83
  cursor       <- Graphics.Win32.loadCursor Nothing Graphics.Win32.iDC_ARROW
 
84
  bgBrush      <- Graphics.Win32.createSolidBrush (Graphics.Win32.rgb 0 0 255)
 
85
  mainInstance <- System.Win32.DLL.getModuleHandle Nothing
 
86
  Graphics.Win32.registerClass
 
87
          ( Graphics.Win32.cS_VREDRAW + Graphics.Win32.cS_HREDRAW
 
88
          , mainInstance
 
89
          , Just icon
 
90
          , Just cursor
 
91
          , Just bgBrush
 
92
          , Nothing
 
93
          , winClass
 
94
          )
 
95
  w <- Graphics.Win32.createWindow
 
96
                 winClass
 
97
                 "Hello, World example"
 
98
                 Graphics.Win32.wS_OVERLAPPEDWINDOW
 
99
                 Nothing Nothing -- leave it to the shell to decide the position
 
100
                                 -- at where to put the window initially
 
101
                 (Just width)
 
102
                 (Just height)
 
103
                 Nothing      -- no parent, i.e, root window is the parent.
 
104
                 Nothing      -- no menu handle
 
105
                 mainInstance
 
106
                 wndProc
 
107
  Graphics.Win32.showWindow w Graphics.Win32.sW_SHOWNORMAL
 
108
  Graphics.Win32.updateWindow w
 
109
  return w
 
110
 
 
111
messagePump :: Graphics.Win32.HWND -> IO ()
 
112
messagePump hwnd = Graphics.Win32.allocaMessage $ \ msg ->
 
113
  let pump = do
 
114
        Graphics.Win32.getMessage msg (Just hwnd)
 
115
                `catch` \ _ -> exitWith ExitSuccess
 
116
        Graphics.Win32.translateMessage msg
 
117
        Graphics.Win32.dispatchMessage msg
 
118
        pump
 
119
  in pump
 
120
 
 
121
paintWith :: Graphics.Win32.LPPAINTSTRUCT -> Graphics.Win32.HWND -> (Graphics.Win32.HDC -> IO a) -> IO a
 
122
paintWith lpps hwnd p =
 
123
  bracket
 
124
    (Graphics.Win32.beginPaint hwnd lpps)
 
125
    (const $ Graphics.Win32.endPaint hwnd lpps)
 
126
    p
 
127
 
 
128
\end{code}