http://www.codepedia.com/1/Win32APIHelloWorld
펼쳐두기..
--
-- http://www.codepedia.com/1/Win32APIHelloWorld
--
-- haskell 에 Win32 패키지가 있길래 대강 구글링해서 찾은 아래 코드를
-- haskell 로 옮겨보려고 시도해봤다. 창을 띄우긴 했지만 여러모로
-- 문제가 남은 상태..
--
-- Win32 패키지로 GUI 코딩하는건 미친짓이다.
-- C++ 로 api 써서 창띄우는것도 짜증나는 일인데..
--
import Control.Exception
import Control.Monad
import Foreign
import Graphics.Win32
import System.Exit
import System.Win32
import Data.Bits
-- 시작부터 어려웠다. ClassName 만드는데 mkClassName 이 쓰인다는거
-- 알아내는것부터 시작해서 hInstance 얻어오기 등등..
--
-- 어쨌거나 기본적인 win32 어플을 돌리기 위한 RegiserClass,
-- CreateWindow, ShowWindow, UpdateWindow, GetMessage, DispatchMessge
-- 등은 모두 불러 쓸수 있다.
--
main = do
inst <- getModuleHandle Nothing -- WinMain 은 인자로 주지만 여기선 그런거 없다.
className <- newTString "Hello" -- 이거 메모리 안새나? 코드 따라가보면 runRegionT 까지 떨어지는데 저게 뭔지 당최 모르겠네.. 아 mkClassName 이라고 unsafe 함수도 있으니 기억해두자
atom <- register inst className -- 리턴받아봐야 쓸모없지만 코드를 이쁘게 할라고..
hwnd <- create inst className 400 300 "안녕" wndProc
wasVisible <- showWindow hwnd sW_SHOWNORMAL -- 마찬가지 리턴받을 필요 없지만..
() <- updateWindow hwnd
messagePump hwnd
-- 윈도 클래스 등록
register inst className = do
let style = foldr1 (.|.) [cS_VREDRAW, cS_HREDRAW]
icon = Nothing -- loadIcon
cursor = Nothing -- loadCursor
brush = Nothing -- getStockBrush,...
menuName = Nothing
registerClass (style, inst, icon, cursor, brush, menuName, className)
-- 윈도 생성
create inst className width height title wndProc =
let wndName = title
style = wS_OVERLAPPEDWINDOW
x = Nothing
y = Nothing
w = Just width
h = Just height
parent = Nothing
menu = Nothing
proc = wndProc
in do
createWindow className wndName style x y w h parent menu inst proc
-- 메시지 펌프, getMessage 리턴값보고 깔끔하게 종료하는 부분은 못짰음
messagePump :: HWND -> IO ()
messagePump hwnd = allocaMessage loop
where loop wm = forever $ do
getMessage wm (Just hwnd) -- 음 종료처리를 어떻게 하지? getMessage 에서 FALSE 리턴 주기 전에 익셉션이 떨어져버린다. 예외 잡아야 하나?
dispatchMessage wm
-- 윈도 프로시져.. 씨바 존내 성가심. WM_PAINT 에 뭔가 그럴듯한거 뿌리려다 그냥 포기했다.
wndProc :: WindowClosure
wndProc hwnd wm wparam lparam
| wm == wM_DESTROY = do
-- 어라.. postQuitMessage 가 없다.
-- postMessage 도 없다.
-- 소스 뒤져보면 postMessage 는 TODO 로 표기되어있다...
-- 그리고 WM_QUIT 보내면 getMessage 에서 FALSE 떨어질줄 알았는데 여전히 익셉션만 잡힌다...
sendMessage hwnd wM_QUIT 0 0
print "quit"
return 0
| wm == wM_PAINT =
allocaPAINTSTRUCT $ \ps -> do
withDC hwnd ps $ \dc -> do
-- 어라.. drawText 뭐 이런게 안보인다. 만만한 도형이나 몇개 그려보자
rc <- getClientRect hwnd
brush <- createSolidBrush $ rgb 100 100 100
fillRect dc rc brush
deleteBrush brush
brush <- createSolidBrush $ rgb 200 200 200
fillRect dc (10,10,100,100) brush
deleteBrush brush
return 1
| otherwise =
defWindowProc (Just hwnd) wm wparam lparam
-- begin..end 는 전형적인 bracket 사용케이스겠지. 근데 이걸 쓰니 읽기가 더 흉하다?
withDC :: HWND -> LPPAINTSTRUCT -> (HDC -> IO a) -> IO a
withDC hwnd ps body = bracket open close body where
open = beginPaint hwnd ps
close _ = endPaint hwnd ps
