-3
    {- 2012-05-16

    ghc --make -optl-mwindows fileName.hs

option -mwindows is passed to the linker!
attempting to read from stdin with -mwindows may cause a runtime error
any output on stdout/stderr will be lost.
ghc links console app with stdout/stderr as default
-}



--import Graphics.Win32
import Graphics.Win32 hiding (messageBox, c_MessageBox) -- bugfix
import System.Win32.DLL
import Control.Exception (bracket)
import Foreign
import System.Exit




-- bugfix whole msg box
messageBox :: HWND -> String -> String -> MBStyle -> IO MBStatus
messageBox wnd text caption style =
  withTString text $ \ c_text ->
  withTString caption $ \ c_caption ->
  failIfZero "MessageBox" $ c_MessageBox wnd c_text c_caption style
foreign import stdcall safe "windows.h MessageBoxW"
  c_MessageBox :: HWND -> LPCTSTR -> LPCTSTR -> MBStyle -> IO MBStatus


main :: IO ()
main = do
    mainInstance <- getModuleHandle Nothing
    hwnd <- createWindow_ 200 200 wndProc mainInstance
    createButton_ hwnd mainInstance
    messagePump hwnd

wndProc :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT
wndProc hwnd wmsg wParam lParam
    | wmsg == wM_DESTROY = do
        sendMessage hwnd wM_QUIT 1 0
        return 0
    | wmsg == wM_COMMAND && wParam == 3 = do
        messageBox nullPtr "You pressed me." "Haskell msg" 0
        return 0
    | otherwise = defWindowProc (Just hwnd) wmsg wParam lParam


createWindow_ :: Int -> Int -> WindowClosure -> HINSTANCE -> IO HWND
createWindow_ width height wndProc mainInstance = do
    let winClass = mkClassName "Window Empty"
    icon <- loadIcon Nothing iDI_APPLICATION
    cursor <- loadCursor Nothing iDC_ARROW
    bgBrush <- createSolidBrush (rgb 255 0 0)
    registerClass (cS_VREDRAW + cS_HREDRAW, mainInstance, Just icon, Just cursor, Just bgBrush, Nothing, winClass)
    w <- createWindow winClass "Window Empty" wS_OVERLAPPEDWINDOW Nothing Nothing (Just width) (Just height) Nothing Nothing mainInstance wndProc
    showWindow w sW_SHOWNORMAL
    updateWindow w
    return w


createButton_ :: HWND -> HINSTANCE -> IO ()
createButton_ hwnd mainInstance = do
    hBtn <- createButton "Button test" wS_EX_CLIENTEDGE (bS_PUSHBUTTON + wS_VISIBLE + wS_CHILD) (Just 50) (Just 80) (Just 80) (Just 20) (Just hwnd) (Just (castUINTToPtr 3)) mainInstance
    return ()


messagePump :: HWND -> IO ()
messagePump hwnd = allocaMessage $ \ msg ->
    let pump = do
        getMessage msg (Just hwnd) `catch` \ _ -> exitWith ExitSuccess
        translateMessage msg
        dispatchMessage msg
        pump
    in pump

原始链接在这里

用法:复制/粘贴代码,将其保存在一个文件中,使用它进行编译,ghc --make -optl-mwindows fileName.hs它将创建一个漂亮的小窗口。这是基本的 C/C++ 像这里

这个和下面的另外两个示例只是我可以找到用 Haskell 编写的原始createWindow 代码:(

我的反问:

  • 我非常了解 C++ 过程。您创建来函数,如果某些 win_msg 为真,winProc 将调用它......
    但是,这不是唯一的方法。很快,MS 就把它放在了 mfc 类中。我们有 EventListeners,它们基本上做同样的事情。而不是直接测试您创建/添加事件监听器的 win_msg,传递所需的函数并且它可以工作。
    但是代码分组更好,更易于维护,并且更像 OO。

  • Haskell 用于 Haskellising winProc 的方法是什么?可能有一些方法可以模仿 addEventListener(evt, my_func)。
    那个代码会是什么样子?有多少种不同的解决方案?它可以使用吗?

  • 更重要的是,是否有一些我不知道的类似 Haskell 的(更好的)方式?

  • 您可以通过哪些方式使用该代码,对其进行一些改进并创建类似 wxWidgets 或 gtk 的东西,但极其简化、易于理解等。
4

1 回答 1

1

这是 createWindow 的第二个版本。关联

略有不同,但不幸的是没有任何评论,或解释为什么有些事情会这样。更不用说它已经13岁了!

是第三个。注意是日文,需要翻译。这三个只是我可以在网上找到的 Haskell win32 createWindow 文件!

没有评论,没有解释,什么都没有:(

%
% (c) sof, 1999
%

Haskell version of "Hello, World" using the Win32 library.
Demonstrates how the Win32 library can be put to use.

Works with Hugs and GHC. To compile it up using the latter,
do: "ghc -o main hello.lhs -syslib win32 -fglasgow-exts"

For GHC 5.03:

  ghc -package win32 hello.lhs -o hello.exe -optl "-Wl,--subsystem,windows"

\begin{code}
module Main(main) where

import qualified Graphics.Win32
import qualified System.Win32.DLL
import qualified System.Win32.Types
import Control.Exception (bracket)
import Foreign
import System.Exit
{-import Addr-}
\end{code}

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).

\begin{code}
main :: IO ()
main =
  Graphics.Win32.allocaPAINTSTRUCT $ \ lpps -> do
  hwnd <- createWindow 200 200 (wndProc lpps onPaint)
  messagePump hwnd

{-
 OnPaint handler for a window - draw a string centred
 inside it.
-}
onPaint :: Graphics.Win32.RECT -> Graphics.Win32.HDC -> IO ()
onPaint (_,_,w,h) hdc = do
   Graphics.Win32.setBkMode hdc Graphics.Win32.tRANSPARENT
   Graphics.Win32.setTextColor hdc (Graphics.Win32.rgb 255 255 0)
   let y | h==10     = 0
         | otherwise = ((h-10) `div` 2)
       x | w==50     = 0
         | otherwise = (w-50) `div` 2
   Graphics.Win32.textOut hdc x y "Hello, world"
   return ()
\end{code}

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).

\begin{code}

wndProc :: Graphics.Win32.LPPAINTSTRUCT
    -> (Graphics.Win32.RECT -> Graphics.Win32.HDC -> IO ()) -- on paint action
        -> Graphics.Win32.HWND
        -> Graphics.Win32.WindowMessage
    -> Graphics.Win32.WPARAM
    -> Graphics.Win32.LPARAM
    -> IO Graphics.Win32.LRESULT
wndProc lpps onPaint hwnd wmsg wParam lParam
 | wmsg == Graphics.Win32.wM_DESTROY = do
     Graphics.Win32.sendMessage hwnd Graphics.Win32.wM_QUIT 1 0
     return 0
 | wmsg == Graphics.Win32.wM_PAINT && hwnd /= nullPtr = do
     r <- Graphics.Win32.getClientRect hwnd
     paintWith lpps hwnd (onPaint r)
     return 0
 | otherwise =
     Graphics.Win32.defWindowProc (Just hwnd) wmsg wParam lParam

createWindow :: Int -> Int -> Graphics.Win32.WindowClosure -> IO Graphics.Win32.HWND
createWindow width height wndProc = do
  let winClass = Graphics.Win32.mkClassName "Hello"
  icon         <- Graphics.Win32.loadIcon   Nothing Graphics.Win32.iDI_APPLICATION
  cursor       <- Graphics.Win32.loadCursor Nothing Graphics.Win32.iDC_ARROW
  bgBrush      <- Graphics.Win32.createSolidBrush (Graphics.Win32.rgb 0 0 255)
  mainInstance <- System.Win32.DLL.getModuleHandle Nothing
  Graphics.Win32.registerClass
      ( Graphics.Win32.cS_VREDRAW + Graphics.Win32.cS_HREDRAW
      , mainInstance
      , Just icon
      , Just cursor
      , Just bgBrush
      , Nothing
      , winClass
      )
  w <- Graphics.Win32.createWindow
         winClass
         "Hello, World example"
         Graphics.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
  Graphics.Win32.showWindow w Graphics.Win32.sW_SHOWNORMAL
  Graphics.Win32.updateWindow w
  return w

messagePump :: Graphics.Win32.HWND -> IO ()
messagePump hwnd = Graphics.Win32.allocaMessage $ \ msg ->
  let pump = do
        Graphics.Win32.getMessage msg (Just hwnd)
        `catch` \ _ -> exitWith ExitSuccess
    Graphics.Win32.translateMessage msg
    Graphics.Win32.dispatchMessage msg
    pump
  in pump

paintWith :: Graphics.Win32.LPPAINTSTRUCT -> Graphics.Win32.HWND -> (Graphics.Win32.HDC -> IO a) -> IO a
paintWith lpps hwnd p =
  bracket
    (Graphics.Win32.beginPaint hwnd lpps)
    (const $ Graphics.Win32.endPaint hwnd lpps)
    p

\end{code}
于 2012-05-29T21:02:43.920 回答