haskell 로 Win32 HelloWorld 만들어봤다..

haskell 에 Win32 패키지가 어느정도 써먹을수 있는지 궁금해서 google 에서 win32 api hello world 코드를 찾아내서 haskell 로 옮겨봤다. 다시 생각해보면 미친짓이었음.

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