Making Windows executables...

[Juan Carlos Arevalo Baeza]

Seth Kurtzberg wrote:

> Juan Carlos Arevalo Baeza wrote:
>
>>   Thanx! That's exactly what I needed. The swhich was undocumented! :-P
>>
>>   :-) I understand the caveats well enough. You can avoid the 
>> exceptions very easily using this code:
>>
>> ---8<--------------------------------------
>> import Foreign.C.Types
>> import Foreign.C.String
>>
>> foreign import ccall unsafe "HsBase.h __hscore_open" c_open :: 
>> CString -> CInt -> CInt -> IO CInt
>> foreign import ccall unsafe "HsBase.h dup2" dup2 :: CInt -> CInt -> 
>> IO CInt
>>
>> open fname oflag pmode = withCString fname $ \c_fname -> c_open 
>> c_fname oflag pmode
>>
>> main =
>>    fd <- open "nul" 2 0
>>    dup2 fd 0
>>    dup2 fd 1
>>    dup2 fd 2
>
>
> I guess Windows can make even Haskell programs look ugly.  Or at the 
> very least esthetically unpleasing.  :)


   He he... I seriously doubt that Windows has much to do with the 
uglyness in thic case, as the above code is just a workarround for a 
shortcoming in the compiler more than anything else, but yes. Win32 
programming is very imperative, so it doesn't look very good in Haskell. 
Nothing much to do about that. OpenGL is just as bad (or worse - it adds 
the concept of the hidden "current" context).

   Incidentally, given that the Win32 (and HGL too!) support in GHC 6.4 
was so completely broken that it doesn't even compile, I've been 
learning FFI by implementing my own bindings for Win32. I took to 
porting Raymond Chen's chinese dictionary example:

http://blogs.msdn.com/oldnewthing/archive/2005/04/22/410773.aspx
http://blogs.msdn.com/oldnewthing/archive/2005/05/10/415991.aspx
http://blogs.msdn.com/oldnewthing/archive/2005/05/11/416430.aspx
http://blogs.msdn.com/oldnewthing/archive/2005/05/13/417183.aspx
http://blogs.msdn.com/oldnewthing/archive/2005/05/16/417865.aspx
http://blogs.msdn.com/oldnewthing/archive/2005/05/18/419130.aspx
http://blogs.msdn.com/oldnewthing/archive/2005/05/19/420038.aspx
http://blogs.msdn.com/oldnewthing/archive/2005/06/13/428534.aspx
http://blogs.msdn.com/oldnewthing/archive/2005/06/14/428892.aspx
http://blogs.msdn.com/oldnewthing/archive/2005/06/15/429338.aspx
http://blogs.msdn.com/oldnewthing/archive/2005/07/11/437522.aspx
http://blogs.msdn.com/oldnewthing/archive/2005/07/12/437974.aspx
http://blogs.msdn.com/oldnewthing/archive/2005/07/13/438381.aspx
http://blogs.msdn.com/oldnewthing/archive/2005/08/11/450383.aspx
http://blogs.msdn.com/oldnewthing/archive/2005/08/12/450818.aspx

   and added all the platform support I needed into Haskell to get the 
program working. It works very well: I didn't even need to use any C 
code at all, just FFI. There's something to be said about the 
possibility of doing the mesage-handling callback like so (and don't 
look at the hardcoded peeks and pokes, please ;-)):

---8<---------------------------------------
mainWindowProc :: IORef MainWindowData -> WNDPROC

mainWindowProc wdataRef hwnd msg wParam lParam
    ...

    | msg == wM_PAINT = do
        withPaint hwnd $ \dc ps -> do
            return 0
        return 0

    | msg == wM_CLOSE = do
        postQuitMessage 0
        return 1

    | msg == wM_COMMAND = do
        let id  = loWORD wParam
        let cmd = CMD $ hiWORD wParam
        when_ (id == 2 && cmd == eN_CHANGE) $ do
            refilterRef wdataRef
        defWindowProc hwnd msg wParam lParam

    | msg == wM_NOTIFY = do
        let p = nullPtr `plusPtr` fromIntegral lParam
        wdata <- readIORef wdataRef
        let lvHwnd = lvWindow wdata
        childHwnd <- peekByteOff p 0
        --childId   <- peekByteOff p 4
        code      <- peekByteOff p 8
        case code of

            _| code == lVN_GETDISPINFO -> do
                i <- peekByteOff p 16 :: IO INT
                when_ ((i >= 0) && (i < (fromIntegral $ dictIndexSize 
wdata))) $ do
                    mask <- peekByteOff p 12
                    when_ ((mask .&. lVIF_TEXT) /= LVIF 0) $ do
                        let (trad, simp, pinyin, english) = dict wdata ! 
(dictIndex wdata ! fromIntegral i)
                        col <- peekByteOff p 20 :: IO INT
                        pokeByteOff p 32 $ case col of
                            _| col == cOL_TRAD    -> trad
                            _| col == cOL_SIMP    -> simp
                            _| col == cOL_PINYIN  -> pinyin
                            _| col == cOL_ENGLISH -> english
                    when_ ((mask .&. lVIF_IMAGE) /= LVIF 0) $ do
                        pokeByteOff p 40 (-1 :: INT)
                    when_ ((mask .&. lVIF_STATE) /= LVIF 0) $ do
                        pokeByteOff p 24 (0 :: UINT)
                return 0

            _| code == nM_CUSTOMDRAW && lvHwnd == childHwnd -> do
                drawStage <- peekByteOff p 12
                case drawStage of

                    _| drawStage == cDDS_PREPAINT -> return 
cDRF_NOTIFYITEMDRAW

                    _| drawStage == cDDS_ITEMPREPAINT -> do
                        clrText <- peekByteOff p 48
                        writeIORef wdataRef $ wdata { normalTextColor = 
clrText }
                        return cDRF_NOTIFYSUBITEMDRAW

                    _| drawStage == cDDS_SUBITEMPREPAINT -> do
                        itemSpec <- peekByteOff p 36 :: IO DWORD
                        subItem <- peekByteOff p 56
                        if subItem == cOL_PINYIN && itemSpec < 
(fromIntegral $ arrayLength $ dict wdata) then do
                                let (ctrad, csimp, cpinyin, cenglish) = 
dict wdata ! fromIntegral itemSpec
                                pinyin <- peekCWString cpinyin
                                if pinyin == "" || head pinyin == 'a' then
                                        pokeByteOff p 48 $ rgb 0x80 0 0x80
                                    else
                                        pokeByteOff p 48 $ 
normalTextColor wdata
                            else
                                pokeByteOff p 48 $ normalTextColor wdata
                        return cDRF_DODEFAULT

                    otherwise -> do
                        return cDRF_DODEFAULT

            otherwise -> do
                return 0

    | msg == wM_NOTIFYFORMAT = do
        return nFR_UNICODE

    | otherwise =
        defWindowProc hwnd msg wParam lParam
---8<---------------------------------------

   Hopefully, I'll find better ways to expose different things to the 
Haskell program. Like proper lazy access to parameters passed by pointer 
to structure (I started a thread about this in Haskell Cafe), or a 
better way to dispatch the messages (Hash?).

JCAB