Commits

Anonymous committed f6aa8eb

[project @ 2003-04-05 18:00:34 by reid]
Initial commit of Win32. GreenCard, GHC and Haddock accept the code but I haven't linked it (because I'm doing this phase of the work on my Unix box)

Comments (0)

Files changed (48)

+# -----------------------------------------------------------------------------
+# $Id: Makefile,v 1.1 2003/04/05 18:00:24 reid Exp $
+
+TOP = ..
+include $(TOP)/mk/boilerplate.mk
+
+# -----------------------------------------------------------------------------
+
+# Comment out if you want to do initial debugging on Unix systems
+SUBDIRS = cbits
+
+ALL_DIRS = \
+	System \
+	System/Win32 
+
+PACKAGE = Win32
+PACKAGE_DEPS = base
+
+SRC_CC_OPTS += -Wall -I../include -I.
+SRC_CC_OPTS += -I$(GHC_INCLUDE_DIR) -I$(GHC_RUNTIME_DIR)
+
+SRC_HC_OPTS += -Wall -fffi -cpp -fglasgow-exts -package lang
+GC_OPTS += --target=ffi 
+
+SRC_HADDOCK_OPTS += -t "Win32 Libraries (Win32 package)"
+
+# yeuch, have to get Win32_CFLAGS & Win32_LIBS in through CPP to Win32.conf.in
+comma = ,
+PACKAGE_CPP_OPTS += -DWIN32_CFLAGS='$(patsubst %,$(comma)"%",$(WIN32_CFLAGS))'
+PACKAGE_CPP_OPTS += -DWIN32_LIBS='$(patsubst %,$(comma)"%",$(WIN32_LIBS))'
+
+# -----------------------------------------------------------------------------
+
+# Comment out if you want to do initial debugging on Unix systems
+STUBOBJS += \
+   $(patsubst %.gc,  %_stub_ffi.o, $(GC_SRCS))
+
+# -----------------------------------------------------------------------------
+
+include $(TOP)/mk/target.mk
+module System.Win32
+	( module System.Win32.StdDIS
+	, module System.Win32.GDITypes
+	, module System.Win32.Bitmap
+	, module System.Win32.Brush
+	, module System.Win32.Control
+	, module System.Win32.Clip
+	, module System.Win32.Dialogue
+	, module System.Win32.DLL
+	, module System.Win32.File
+	, module System.Win32.Font
+	, module System.Win32.Graphics2D
+	, module System.Win32.HDC
+	, module System.Win32.Icon
+	, module System.Win32.Key
+	, module System.Win32.Menu
+	, module System.Win32.Misc
+	, module System.Win32.MM
+	, module System.Win32.Palette
+	, module System.Win32.Path
+	, module System.Win32.Pen
+	, module System.Win32.Process
+	, module System.Win32.Region
+	, module System.Win32.Registry
+	, module System.Win32.SystemInfo
+	, module System.Win32.Types
+	, module System.Win32.WinMessage
+	, module System.Win32.Window
+	) where
+
+import System.Win32.StdDIS
+import System.Win32.GDITypes
+import System.Win32.Bitmap
+import System.Win32.Brush
+import System.Win32.Clip
+import System.Win32.Control
+import System.Win32.Dialogue
+import System.Win32.DLL
+import System.Win32.File
+import System.Win32.Font
+import System.Win32.Graphics2D
+import System.Win32.HDC
+import System.Win32.Icon
+import System.Win32.Key
+import System.Win32.Menu
+import System.Win32.Misc
+import System.Win32.MM
+import System.Win32.Palette
+import System.Win32.Path
+import System.Win32.Pen
+import System.Win32.Process
+import System.Win32.Region
+import System.Win32.Registry
+import System.Win32.SystemInfo
+import System.Win32.Types
+import System.Win32.WinMessage
+import System.Win32.Window
+
+----------------------------------------------------------------
+-- End
+----------------------------------------------------------------

System/Win32/Bitmap.gc

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Bitmap
+-- Copyright   :  (c) Alastair Reid, 1997-2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- A collection of GreenCard declarations for interfacing with Win32.
+--
+-----------------------------------------------------------------------------
+
+module System.Win32.Bitmap(
+	
+	RasterOp3,
+	RasterOp4,
+	sRCCOPY,
+	sRCPAINT,
+	sRCAND,
+	sRCINVERT,
+	sRCERASE,
+	nOTSRCCOPY,
+	nOTSRCERASE,
+	mERGECOPY,
+	mERGEPAINT,
+	pATCOPY,
+	pATPAINT,
+	pATINVERT,
+	dSTINVERT,
+	bLACKNESS,
+	wHITENESS,
+	
+	mAKEROP4,
+	
+	BITMAP,
+	LPBITMAP,
+	setBITMAP,
+	marshall_bITMAP_,
+	deleteBitmap,
+	createCompatibleBitmap,
+	createBitmap,
+	createBitmapIndirect,
+	createDIBPatternBrushPt,
+	getBitmapDimensionEx,
+	setBitmapDimensionEx,
+	getBitmapInfo,
+	
+	BitmapCompression,
+	bI_RGB,
+	bI_RLE8,
+	bI_RLE4,
+	bI_BITFIELDS,
+	
+	ColorFormat,
+	dIB_PAL_COLORS,
+	dIB_RGB_COLORS,
+	
+	LPBITMAPINFO,
+	BITMAPINFOHEADER,
+	LPBITMAPINFOHEADER,
+	getBITMAPINFOHEADER_,
+	
+	BITMAPFILEHEADER,
+	LPBITMAPFILEHEADER,
+	getBITMAPFILEHEADER,
+	
+	sizeofBITMAP,
+	sizeofBITMAPINFO,
+	sizeofBITMAPINFOHEADER,
+	sizeofBITMAPFILEHEADER,
+	sizeofLPBITMAPFILEHEADER,
+	
+	createBMPFile,
+	cBM_INIT,
+	getDIBits,
+	setDIBits,
+	createDIBitmap
+
+        ) where
+
+import System.Win32.StdDIS
+import System.Win32.Types
+import System.Win32.GDITypes
+
+%#include "Win32Aux.h"
+%#include <windows.h>
+%#include "errors.h"
+%#include "win32debug.h"
+%#include "finalizers.h"
+
+----------------------------------------------------------------
+-- Resources
+----------------------------------------------------------------
+
+-- Yoiks - name clash
+-- %dis bitmap x = addr ({LPTSTR} x)
+-- 
+-- type Bitmap = LPCTSTR
+-- 
+-- intToBitmap :: Int -> Bitmap
+-- intToBitmap i = makeIntResource (toWord i)
+-- 
+-- %fun LoadBitmap :: MbHINSTANCE -> Bitmap -> IO HBITMAP
+-- %fail { res1 == 0 } { ErrorString("LoadBitmap") }
+--  
+-- %const Bitmap  
+-- % [ OBM_CLOSE        = { MAKEINTRESOURCE(OBM_CLOSE)       }
+-- % , OBM_UPARROW      = { MAKEINTRESOURCE(OBM_UPARROW)     }
+-- % , OBM_DNARROW      = { MAKEINTRESOURCE(OBM_DNARROW)     }
+-- % , OBM_RGARROW      = { MAKEINTRESOURCE(OBM_RGARROW)     }
+-- % , OBM_LFARROW      = { MAKEINTRESOURCE(OBM_LFARROW)     }
+-- % , OBM_REDUCE       = { MAKEINTRESOURCE(OBM_REDUCE)      }
+-- % , OBM_ZOOM         = { MAKEINTRESOURCE(OBM_ZOOM)        }
+-- % , OBM_RESTORE      = { MAKEINTRESOURCE(OBM_RESTORE)     }
+-- % , OBM_REDUCED      = { MAKEINTRESOURCE(OBM_REDUCED)     }
+-- % , OBM_ZOOMD        = { MAKEINTRESOURCE(OBM_ZOOMD)       }
+-- % , OBM_RESTORED     = { MAKEINTRESOURCE(OBM_RESTORED)    }
+-- % , OBM_UPARROWD     = { MAKEINTRESOURCE(OBM_UPARROWD)    }
+-- % , OBM_DNARROWD     = { MAKEINTRESOURCE(OBM_DNARROWD)    }
+-- % , OBM_RGARROWD     = { MAKEINTRESOURCE(OBM_RGARROWD)    }
+-- % , OBM_LFARROWD     = { MAKEINTRESOURCE(OBM_LFARROWD)    }
+-- % , OBM_MNARROW      = { MAKEINTRESOURCE(OBM_MNARROW)     }
+-- % , OBM_COMBO        = { MAKEINTRESOURCE(OBM_COMBO)       }
+-- % , OBM_UPARROWI     = { MAKEINTRESOURCE(OBM_UPARROWI)    }
+-- % , OBM_DNARROWI     = { MAKEINTRESOURCE(OBM_DNARROWI)    }
+-- % , OBM_RGARROWI     = { MAKEINTRESOURCE(OBM_RGARROWI)    }
+-- % , OBM_LFARROWI     = { MAKEINTRESOURCE(OBM_LFARROWI)    }
+-- % , OBM_OLD_CLOSE    = { MAKEINTRESOURCE(OBM_OLD_CLOSE)   }   
+-- % , OBM_SIZE         = { MAKEINTRESOURCE(OBM_SIZE)        }
+-- % , OBM_OLD_UPARROW  = { MAKEINTRESOURCE(OBM_OLD_UPARROW) }   
+-- % , OBM_OLD_DNARROW  = { MAKEINTRESOURCE(OBM_OLD_DNARROW) }   
+-- % , OBM_OLD_RGARROW  = { MAKEINTRESOURCE(OBM_OLD_RGARROW) }   
+-- % , OBM_OLD_LFARROW  = { MAKEINTRESOURCE(OBM_OLD_LFARROW) }   
+-- % , OBM_BTSIZE       = { MAKEINTRESOURCE(OBM_BTSIZE)      }
+-- % , OBM_CHECK        = { MAKEINTRESOURCE(OBM_CHECK)       }
+-- % , OBM_CHECKBOXES   = { MAKEINTRESOURCE(OBM_CHECKBOXES)  }   
+-- % , OBM_BTNCORNERS   = { MAKEINTRESOURCE(OBM_BTNCORNERS)  }   
+-- % , OBM_OLD_REDUCE   = { MAKEINTRESOURCE(OBM_OLD_REDUCE)  }   
+-- % , OBM_OLD_ZOOM     = { MAKEINTRESOURCE(OBM_OLD_ZOOM)    }
+-- % , OBM_OLD_RESTORE  = { MAKEINTRESOURCE(OBM_OLD_RESTORE) }   
+-- % ]
+
+----------------------------------------------------------------
+-- Raster Ops
+----------------------------------------------------------------
+
+%dis rasterOp3 x = word32 x
+%dis rasterOp4 x = word32 x
+
+type RasterOp3 = Word32
+type RasterOp4 = Word32
+
+%const RasterOp3 
+% [ SRCCOPY
+% , SRCPAINT
+% , SRCAND
+% , SRCINVERT
+% , SRCERASE
+% , NOTSRCCOPY
+% , NOTSRCERASE
+% , MERGECOPY  
+% , MERGEPAINT
+% , PATCOPY
+% , PATPAINT
+% , PATINVERT
+% , DSTINVERT
+% , BLACKNESS
+% , WHITENESS
+% ]
+
+%fun MAKEROP4 :: RasterOp3 -> RasterOp3 -> RasterOp4
+
+----------------------------------------------------------------
+-- BITMAP
+----------------------------------------------------------------
+
+type BITMAP =
+  ( LONG    -- bmType
+  , LONG    -- bmWidth
+  , LONG    -- bmHeight
+  , LONG    -- bmWidthBytes
+  , WORD    -- bmPlanes   
+  , WORD    -- bmBitsPixel
+  , LPVOID  -- bmBits
+  )
+
+%dis bitmap x = 
+% ( lONG   {(%x).bmType}
+% , lONG   {(%x).bmWidth}
+% , lONG   {(%x).bmHeight}
+% , lONG   {(%x).bmWidthBytes}
+% , wORD   {(%x).bmPlanes}
+% , wORD   {(%x).bmBitsPixel}
+% , lPVOID {(%x).bmBits}
+% )
+
+%dis lPBITMAP x = addr ({BITMAP *} x)
+type LPBITMAP = Addr
+
+%fun setBITMAP :: LPBITMAP -> BITMAP -> IO ()
+%call (lPBITMAP arg1) (bitmap {*arg1})
+%code
+
+marshall_bITMAP_ :: BITMAP -> IO LPBITMAP
+marshall_bITMAP_ bmp = do
+  lpbmp <- malloc sizeofBITMAP
+  setBITMAP lpbmp bmp
+  return lpbmp
+
+----------------------------------------------------------------
+-- Misc
+----------------------------------------------------------------
+
+%fun deleteBitmap :: HBITMAP -> IO ()
+%code BOOL res = DeleteObject(arg1);
+%fail { !res } { ErrorString("DeleteBitmap") }
+
+%fun CreateCompatibleBitmap :: HDC -> Int32 -> Int32 -> IO HBITMAP
+%fail { res1 == 0 } { ErrorString("CreateCompatibleBitmap") }
+
+%fun CreateBitmap :: INT -> INT -> UINT -> UINT -> MbLPVOID -> IO HBITMAP
+%fail { res1 == 0 } { ErrorString("CreateBitmap") }
+
+%fun CreateBitmapIndirect :: LPBITMAP -> IO HBITMAP
+%fail { res1 == 0 } { ErrorString("CreateBitmapIndirect") }
+
+%fun CreateDIBPatternBrushPt :: LPVOID -> ColorFormat -> IO HBRUSH
+%fail { res1 == 0 } { ErrorString("CreateDIBPatternBrushPt") }
+
+----------------------------------------------------------------
+-- Querying
+----------------------------------------------------------------
+
+%fun getBitmapDimensionEx :: HBITMAP -> IO SIZE
+%call (hBITMAP h)
+%code SIZE sz; 
+%     BOOL success = GetBitmapDimensionEx(h,&sz);
+%fail { !success } { ErrorString("GetBitmapDimensionEx") }
+%result (size {sz})
+
+%fun setBitmapDimensionEx :: HBITMAP -> SIZE -> IO SIZE
+%call (hBITMAP h) (declare {SIZE} sz_in in (size sz_in))
+%code SIZE sz_out;
+%     BOOL success = SetBitmapDimensionEx(h,sz_in.cx,sz_in.cy,&sz_out);
+%fail { !success } { ErrorString("SetBitmapDimensionEx") }
+%result (size {sz_out})
+
+%fun getBitmapInfo :: HBITMAP -> IO BITMAP
+%call (hBITMAP x)
+%code BITMAP bm;
+%     int nbytes = GetObject(x,sizeof(BITMAP),&bm);
+%fail { nbytes != sizeof(BITMAP) } { ErrorWin("getBitmapInfo") }
+%result ( bitmap bm )
+
+----------------------------------------------------------------
+--
+----------------------------------------------------------------
+
+%dis bitmapCompression x = wORD x
+type BitmapCompression = WORD
+
+%const BitmapCompression
+% [ BI_RGB
+% , BI_RLE8
+% , BI_RLE4
+% , BI_BITFIELDS
+% ]
+
+%dis colorFormat x = dWORD x
+type ColorFormat = DWORD
+
+%const ColorFormat
+% [ DIB_PAL_COLORS
+% , DIB_RGB_COLORS
+% ]
+
+----------------------------------------------------------------
+-- BITMAPINFO
+----------------------------------------------------------------
+
+type LPBITMAPINFO = Addr
+%dis lPBITMAPINFO x = addr ({BITMAPINFO *} x)
+
+----------------------------------------------------------------
+-- BITMAPINFOHEADER
+----------------------------------------------------------------
+
+%dis bitmapInfoHeader x = 
+% ( dWORD             {(%x).biSize}
+% , lONG              {(%x).biWidth}
+% , lONG              {(%x).biHeight}
+% , wORD              {(%x).biPlanes}
+% , wORD              {(%x).biBitCount}
+% , bitmapCompression {(%x).biCompression}
+% , dWORD             {(%x).biSizeImage}
+% , lONG              {(%x).biXPelsPerMeter}
+% , lONG              {(%x).biYPelsPerMeter}
+% , maybeT {0} (dWORD {(%x).biClrUsed})
+% , maybeT {0} (dWORD {(%x).biClrImportant})
+% )
+type BITMAPINFOHEADER =
+ ( DWORD              -- biSize      -- sizeof(BITMAPINFOHEADER)
+ , LONG               -- biWidth
+ , LONG               -- biHeight
+ , WORD               -- biPlanes
+ , WORD               -- biBitCount  -- 1, 4, 8, 16, 24 or 32
+ , BitmapCompression  -- biCompression
+ , DWORD              -- biSizeImage
+ , LONG               -- biXPelsPerMeter
+ , LONG               -- biYPelsPerMeter
+ , Maybe DWORD        -- biClrUsed
+ , Maybe DWORD        -- biClrImportant
+ )
+
+%dis lPBITMAPINFOHEADER x = addr ({BITMAPINFOHEADER *} x)
+type LPBITMAPINFOHEADER   = Addr
+
+%fun getBITMAPINFOHEADER_ :: LPBITMAPINFOHEADER -> IO BITMAPINFOHEADER
+%code
+%result (bitmapInfoHeader {*arg1})
+
+
+----------------------------------------------------------------
+-- BITMAPFILEHEADER
+----------------------------------------------------------------
+
+type BITMAPFILEHEADER =
+ ( WORD   -- bfType      -- "BM" == 0x4d42
+ , DWORD  -- bfSize      -- number of bytes in file
+ , WORD   -- bfReserved1 -- == 0
+ , WORD   -- bfReserved2 -- == 0
+ , DWORD  -- bfOffBits   -- == (char*) bits - (char*) filehdr
+ )
+%dis bitmapFileHeader x =
+% ( wORD  {(%x).bfType}
+% , dWORD {(%x).bfSize}
+% , wORD  {(%x).bfReserved1} -- == 0
+% , wORD  {(%x).bfReserved2} -- == 0
+% , dWORD {(%x).bfOffBits}
+% )
+
+type LPBITMAPFILEHEADER = Addr
+%dis lPBITMAPFILEHEADER x = addr ({BITMAPFILEHEADER *} x)
+
+%fun getBITMAPFILEHEADER :: LPBITMAPFILEHEADER -> IO BITMAPFILEHEADER
+%code
+%result (bitmapFileHeader {*arg1})
+
+%const Word32 
+% [ sizeofBITMAP             = { sizeof(BITMAP)           }
+% , sizeofBITMAPINFO         = { sizeof(BITMAPINFO)       }
+% , sizeofBITMAPINFOHEADER   = { sizeof(BITMAPINFOHEADER) }
+% , sizeofBITMAPFILEHEADER   = { sizeof(BITMAPFILEHEADER) }
+% , sizeofLPBITMAPFILEHEADER = { sizeof(BITMAPFILEHEADER) } 
+% ]
+
+----------------------------------------------------------------
+-- CreateBMPFile
+----------------------------------------------------------------
+
+-- A (large) helper function - courtesy of Microsoft
+
+-- Includes "dumpBMP.c" for non-ghc backends.
+%#include "dumpBMP.h"
+
+%fun CreateBMPFile :: String -> HBITMAP -> HDC -> IO ()
+
+----------------------------------------------------------------
+-- Device Independent Bitmaps
+----------------------------------------------------------------
+
+%const DWORD [ CBM_INIT ]
+
+%fun GetDIBits :: HDC -> HBITMAP -> INT -> INT -> MbLPVOID -> LPBITMAPINFO -> ColorFormat -> IO INT
+%fail { res1 == 0 } { ErrorString("GetDIBits") }
+
+%fun SetDIBits :: HDC -> HBITMAP -> INT -> INT -> LPVOID -> LPBITMAPINFO -> ColorFormat -> IO INT
+%fail { res1 == 0 } { ErrorWin("SetDIBits") }
+
+%fun CreateDIBitmap :: HDC -> LPBITMAPINFOHEADER -> DWORD -> LPVOID -> LPBITMAPINFO -> ColorFormat -> IO HBITMAP
+%fail { res1 == 0 } { ErrorString("CreateDIBitmap") }
+
+----------------------------------------------------------------
+-- End
+----------------------------------------------------------------
+
+

System/Win32/Brush.gc

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Brush
+-- Copyright   :  (c) Alastair Reid, 1997-2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- A collection of GreenCard declarations for interfacing with Win32.
+--
+-----------------------------------------------------------------------------
+
+module System.Win32.Brush where
+
+import System.Win32.StdDIS
+import System.Win32.Types
+import System.Win32.GDITypes
+
+%#include <windows.h>
+%#include "errors.h"
+%#include "win32debug.h"
+%#include "finalizers.h"
+
+----------------------------------------------------------------
+-- Brush
+----------------------------------------------------------------
+
+%fun CreateSolidBrush :: COLORREF -> IO HBRUSH
+%fail { res1 == (HBRUSH) NULL } { ErrorString("CreateSolidBrush") }
+
+%fun CreateHatchBrush :: HatchStyle -> COLORREF -> IO HBRUSH
+%fail { res1 == (HBRUSH) NULL } { ErrorString("CreateHatchBrush") }
+
+%fun CreatePatternBrush :: HBITMAP -> IO HBRUSH
+%fail { res1 == (HBRUSH) NULL } { ErrorString("CreatePatternBrush") }
+
+%fun deleteBrush :: HBRUSH -> IO ()
+%code BOOL success = DeleteObject(arg1);
+%fail { !success } { ErrorString("DeleteBrush") }
+
+----------------------------------------------------------------
+
+%dis stockBrush x = wORD x
+type StockBrush   = WORD
+
+%const StockBrush
+% [ WHITE_BRUSH
+% , LTGRAY_BRUSH
+% , GRAY_BRUSH
+% , DKGRAY_BRUSH
+% , BLACK_BRUSH
+% , NULL_BRUSH
+% , HOLLOW_BRUSH
+% ]
+
+%fun GetStockBrush :: StockBrush -> IO HBRUSH
+%code res1 = GetStockObject(arg1);
+%fail { res1 == (HBRUSH) NULL } { ErrorString("GetStockBrush") }
+
+----------------------------------------------------------------
+-- End
+----------------------------------------------------------------
+

System/Win32/Clip.gc

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Clip
+-- Copyright   :  (c) Alastair Reid, 1997-2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- A collection of GreenCard declarations for interfacing with Win32.
+--
+-----------------------------------------------------------------------------
+
+module System.Win32.Clip where
+
+import System.Win32.StdDIS
+import System.Win32.Types
+import System.Win32.GDITypes
+import System.Win32.WinMessage
+
+%#include <windows.h>
+%#include "errors.h"
+%#include "win32debug.h"
+%#include "finalizers.h"
+
+type ClipboardFormat = UINT
+%dis clipboardFormat x = uINT x
+
+%const ClipboardFormat
+% [ CF_BITMAP
+% , CF_DIB
+% , CF_DIF
+% , CF_DSPBITMAP
+% , CF_DSPENHMETAFILE
+% , CF_DSPMETAFILEPICT
+% , CF_DSPTEXT
+% , CF_ENHMETAFILE
+% , CF_GDIOBJFIRST
+% , CF_HDROP
+% , CF_LOCALE
+% , CF_METAFILEPICT
+% , CF_OEMTEXT
+% , CF_OWNERDISPLAY
+% , CF_PALETTE
+% , CF_PENDATA
+% , CF_PRIVATEFIRST
+% , CF_PRIVATELAST
+% , CF_RIFF
+% , CF_SYLK
+% , CF_TEXT
+% , CF_WAVE
+% , CF_TIFF
+% ] 
+
+-- % , CF_UNICODETEXT  -- WinNT only
+
+%fun ChangeClipboardChain :: HWND -> HWND -> IO Bool
+
+%fun CloseClipboard :: IO ()
+%code BOOL res1=CloseClipboard()
+%fail {res1==0}{ErrorWin("CloseClipboard")}
+
+%fun CountClipboardFormats :: IO Int
+
+%fun EmptyClipboard :: IO ()
+%code BOOL res1=EmptyClipboard()
+%fail {res1==0}{ErrorWin("EmptyClipboard")}
+
+%fun EnumClipboardFormats :: UINT -> IO UINT
+%code UINT res1=EnumClipboardFormats(arg1);
+%fail {res1==0 && GetLastError() != NO_ERROR}{ErrorWin("EnumClipboardFormats")}
+
+%fun GetClipboardData :: ClipboardFormat -> IO HANDLE
+%fail {res1==NULL}{ErrorWin("GetClipboardData")}
+
+%fun GetClipboardFormatName :: ClipboardFormat -> Addr -> Int -> IO Int
+%fail {res1==0}{ErrorWin("GetClipboardFormatName")}
+
+%fun GetClipboardOwner :: IO HWND
+%fail {res1==NULL}{ErrorWin("GetClipboardOwner")}
+
+%fun GetClipboardViewer :: IO HWND
+%fail {res1==NULL}{ErrorWin("GetClipboardViewer")}
+
+%fun GetOpenClipboardWindow :: IO HWND
+%fail {res1==NULL}{ErrorWin("GetClipboardWindow")}
+
+%fun GetPriorityClipboardFormat :: Addr -> Int -> IO Int
+%fail {res1==-1}{ErrorWin("GetPriorityClipboardFormat")}
+
+%fun IsClipboardFormatAvailable :: ClipboardFormat -> IO BOOL
+
+%fun OpenClipboard :: HWND -> IO ()
+%code BOOL res1=OpenClipboard(arg1);
+%fail {res1==0}{ErrorWin("OpenClipboard")}
+
+%fun RegisterClipboardFormat :: String -> IO ClipboardFormat
+%fail {res1==0}{ErrorWin("RegisterClipboardFormat")}
+
+%fun SetClipboardData :: ClipboardFormat -> HANDLE -> IO HANDLE
+%fail {res1==NULL}{ErrorWin("SetClipboardData")}
+
+%fun SetClipboardViewer :: HWND -> IO HWND
+%fail {res1==NULL}{ErrorWin("SetClipboardViewer")}
+
+
+
+
+
+
+

System/Win32/Control.gc

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Control
+-- Copyright   :  (c) Alastair Reid, 1997-2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- A collection of GreenCard declarations for interfacing with Win32.
+--
+-----------------------------------------------------------------------------
+
+module System.Win32.Control where
+
+import System.Win32.StdDIS
+import System.Win32.Types
+import System.Win32.GDITypes
+import System.Win32.Window
+import System.Win32.WinMessage
+
+%#include <windows.h>
+%#include <commctrl.h>
+%#include "errors.h"
+%#include "win32debug.h"
+
+-- Bindings to the various standard Win32 controls
+
+
+-- == Command buttons
+
+%dis buttonStyle x = windowStyle x
+type ButtonStyle   = WindowStyle
+
+%const ButtonStyle 
+% [ BS_PUSHBUTTON
+% , BS_DEFPUSHBUTTON
+% , BS_CHECKBOX
+% , BS_AUTOCHECKBOX
+% , BS_RADIOBUTTON
+% , BS_3STATE
+% , BS_AUTO3STATE
+% , BS_GROUPBOX
+% , BS_AUTORADIOBUTTON
+% , BS_OWNERDRAW
+% , BS_LEFTTEXT
+% , BS_USERBUTTON
+% ]
+
+%fun createButton 
+%    :: String -> WindowStyle -> ButtonStyle 
+%    -> MbPos -> MbPos -> MbPos -> MbPos 
+%    -> MbHWND -> MbHMENU -> HANDLE 
+%    -> IO HWND
+%call (string nm) (windowStyle wstyle) (buttonStyle bstyle) 
+%     (mbPos x) (mbPos y) (mbPos w) (mbPos h) 
+%     (mbHWND parent) (mbHMENU hmenu) (hANDLE handle)
+%code hwnd = CreateWindow("BUTTON",nm,wstyle|bstyle,x,y,w,h,parent,hmenu,handle,NULL);
+%fail { hwnd == NULL } { ErrorWin("CreateButton") }
+%result (hWND hwnd)
+
+type ButtonState = UINT
+%dis buttonState x = uINT x
+
+%const ButtonState [ BST_CHECKED, BST_INDETERMINATE, BST_UNCHECKED ]
+
+%fun CheckDlgButton :: HWND -> Int -> ButtonState -> IO ()
+%code BOOL res1=CheckDlgButton(arg1,arg2,arg3);
+%fail { res1 == FALSE } {ErrorWithCode("CheckDlgButton", res1)}
+
+%fun CheckRadioButton :: HWND -> Int -> Int -> Int -> IO ()
+%code BOOL res1=CheckRadioButton(arg1,arg2,arg3,arg4);
+%fail { res1 == FALSE } {ErrorWithCode("CheckRadioButton", res1)}
+
+%fun IsDlgButtonChecked :: HWND -> Int -> IO ButtonState
+%code BOOL res1=IsDlgButtonChecked(arg1,arg2);
+%fail { res1 == FALSE } {ErrorWithCode("IsDlgButtonChecked", res1)}
+
+
+-- == ComboBoxes aka. pop up list boxes/selectors.
+
+%dis comboBoxStyle x = windowStyle x
+type ComboBoxStyle = WindowStyle
+
+%const ComboBoxStyle 
+% [ CBS_SIMPLE
+% , CBS_DROPDOWN
+% , CBS_DROPDOWNLIST
+% , CBS_OWNERDRAWFIXED
+% , CBS_OWNERDRAWVARIABLE
+% , CBS_AUTOHSCROLL
+% , CBS_OEMCONVERT
+% , CBS_SORT
+% , CBS_HASSTRINGS
+% , CBS_NOINTEGRALHEIGHT
+% , CBS_DISABLENOSCROLL
+% ]
+
+%fun createComboBox 
+%    :: String -> WindowStyle -> ComboBoxStyle 
+%    -> MbPos -> MbPos -> MbPos -> MbPos 
+%    -> HWND -> MbHMENU -> HANDLE 
+%    -> IO HWND
+%call (string nm) (windowStyle wstyle) (comboBoxStyle cstyle) 
+%     (mbPos x) (mbPos y) (mbPos w) (mbPos h) 
+%     (hWND parent) (mbHMENU hmenu) (hANDLE handle)
+%code hwnd = CreateWindow("COMBOBOX",nm,wstyle|cstyle, x,y,w,h,parent,hmenu,handle,NULL);
+%fail { hwnd == NULL } { ErrorWin("CreateComboBox") }
+%result (hWND hwnd)
+
+-- see comment about freeing windowNames in System.Win32.Window.createWindow
+-- %end free(nm)
+
+
+--- == Edit controls
+
+----------------------------------------------------------------
+
+%dis editStyle x = windowStyle x
+type EditStyle = WindowStyle
+
+%const EditStyle 
+% [ ES_LEFT
+% , ES_CENTER
+% , ES_RIGHT
+% , ES_MULTILINE
+% , ES_UPPERCASE
+% , ES_LOWERCASE
+% , ES_PASSWORD
+% , ES_AUTOVSCROLL
+% , ES_AUTOHSCROLL
+% , ES_NOHIDESEL
+% , ES_OEMCONVERT
+% , ES_READONLY
+% , ES_WANTRETURN
+% ]
+
+%fun createEditWindow 
+%    :: String -> WindowStyle -> EditStyle 
+%    -> MbPos -> MbPos -> MbPos -> MbPos 
+%    -> HWND -> MbHMENU -> HANDLE 
+%    -> IO HWND
+%call (string nm) (windowStyle wstyle) (editStyle estyle) 
+%     (mbPos x) (mbPos y) (mbPos w) (mbPos h) 
+%     (hWND parent) (mbHMENU hmenu) (hANDLE handle)
+%code hwnd = CreateWindow("EDIT",nm,wstyle|estyle, x,y,w,h,parent,hmenu,handle,NULL);
+%fail { hwnd == NULL } { ErrorWin("CreateEditWindow") }
+%result (hWND hwnd)
+
+-- see comment about freeing windowNames in System.Win32.Window.createWindow
+-- %end free(nm)
+
+-- == List boxes
+
+
+----------------------------------------------------------------
+
+%dis listBoxStyle x = windowStyle x
+type ListBoxStyle   = WindowStyle
+
+%const ListBoxStyle 
+% [ LBS_NOTIFY
+% , LBS_SORT
+% , LBS_NOREDRAW
+% , LBS_MULTIPLESEL
+% , LBS_OWNERDRAWFIXED
+% , LBS_OWNERDRAWVARIABLE
+% , LBS_HASSTRINGS
+% , LBS_USETABSTOPS
+% , LBS_NOINTEGRALHEIGHT
+% , LBS_MULTICOLUMN
+% , LBS_WANTKEYBOARDINPUT
+% , LBS_DISABLENOSCROLL
+% , LBS_STANDARD
+% ]
+
+%fun createListBox 
+%    :: String -> WindowStyle -> ListBoxStyle 
+%    -> MbPos -> MbPos -> MbPos -> MbPos 
+%    -> HWND -> MbHMENU -> HANDLE 
+%    -> IO HWND
+%call (string nm) (windowStyle wstyle) (listBoxStyle lstyle) 
+%     (mbPos x) (mbPos y) (mbPos w) (mbPos h) 
+%     (hWND parent) (mbHMENU hmenu) (hANDLE handle)
+%code hwnd = CreateWindow("LISTBOX",nm,wstyle|lstyle,x,y,w,h,parent,hmenu,handle,NULL);
+%fail { hwnd == NULL } { ErrorWin("CreateListBox") }
+%result (hWND hwnd)
+
+-- see comment about freeing windowNames in System.Win32.Window.createWindow
+-- %end free(nm)
+
+-- == Scrollbars
+
+
+----------------------------------------------------------------
+
+%dis scrollbarStyle x = windowStyle x
+type ScrollbarStyle = WindowStyle
+
+%const ScrollbarStyle 
+% [ SBS_HORZ
+% , SBS_TOPALIGN
+% , SBS_BOTTOMALIGN
+% , SBS_VERT
+% , SBS_LEFTALIGN
+% , SBS_RIGHTALIGN
+% , SBS_SIZEBOX
+% , SBS_SIZEBOXTOPLEFTALIGN
+% , SBS_SIZEBOXBOTTOMRIGHTALIGN
+% ]
+
+%fun createScrollbar 
+%    :: String -> WindowStyle -> ScrollbarStyle 
+%    -> MbPos -> MbPos -> MbPos -> MbPos 
+%    -> HWND -> MbHMENU -> HANDLE 
+%    -> IO HWND
+%call (string nm) (windowStyle wstyle) (scrollbarStyle sstyle) 
+%     (mbPos x) (mbPos y) (mbPos w) (mbPos h) 
+%     (hWND parent) (mbHMENU hmenu) (hANDLE handle)
+%code hwnd = CreateWindow("SCROLLBAR",nm,wstyle|sstyle, x,y,w,h,parent,hmenu,handle,NULL);
+%fail { hwnd == NULL } { ErrorWin("CreateScrollbar") }
+%result (hWND hwnd)
+
+-- see comment about freeing windowNames in System.Win32.Window.createWindow
+-- %end free(nm)
+
+-- == Static controls aka. labels
+
+
+----------------------------------------------------------------
+
+%dis staticControlStyle x = windowStyle x
+type StaticControlStyle = WindowStyle
+
+%const StaticControlStyle 
+% [ SS_LEFT
+% , SS_CENTER
+% , SS_RIGHT
+% , SS_ICON
+% , SS_BLACKRECT
+% , SS_GRAYRECT
+% , SS_WHITERECT
+% , SS_BLACKFRAME
+% , SS_GRAYFRAME
+% , SS_WHITEFRAME
+% , SS_SIMPLE
+% , SS_LEFTNOWORDWRAP
+% , SS_NOPREFIX
+% ]
+
+%fun createStaticWindow 
+%    :: String -> WindowStyle -> StaticControlStyle 
+%    -> MbPos -> MbPos -> MbPos -> MbPos 
+%    -> HWND -> MbHMENU -> HANDLE 
+%    -> IO HWND
+%call (string nm) (windowStyle wstyle) (staticControlStyle sstyle) 
+%     (mbPos x) (mbPos y) (mbPos w) (mbPos h) 
+%     (hWND parent) (mbHMENU hmenu) (hANDLE handle)
+%code hwnd = CreateWindow("STATIC",nm,wstyle|sstyle, x,y,w,h,parent,hmenu,handle,NULL);
+%fail { hwnd == NULL } { ErrorWin("CreateStaticWindow") }
+%result (hWND hwnd)
+
+-- see comment about freeing windowNames in System.Win32.Window.createWindow
+-- %end free(nm)
+
+{- UNTESTED - leave out
+
+type CommonControl   = Addr
+%dis commonControl x = addr ({LPCTSTR} x)
+
+%const CommonControl
+% [ ToolTipsControl = {TOOLTIPS_CLASS}
+% , TrackBarControl = {TRACKBAR_CLASS}
+% , UpDownControl  = {UPDOWN_CLASS}
+% , ProgressBarControl = {PROGRESS_CLASS}
+% , HotKeyControl  = {HOTKEY_CLASS}
+% , AnimateControl     = {ANIMATE_CLASS}
+% , StatusControl     =  {STATUSCLASSNAME}
+% , HeaderControl     =  {WC_HEADER}
+% , ListViewControl   =  {WC_LISTVIEW}
+% , TabControl        =  {WC_TABCONTROL}
+% , TreeViewControl   =  {WC_TREEVIEW}
+% , MonthCalControl    = {MONTHCAL_CLASS}
+% , DateTimePickControl = {DATETIMEPICK_CLASS}
+% , ReBarControl      =  {REBARCLASSNAME}
+-- Not supplied in mingw-20001111
+--% , ComboBoxExControl =  {WC_COMBOBOXEX}
+--% , IPAddressControl  =  {WC_IPADDRESS}
+--% , PageScrollerControl = {WC_PAGESCROLLER}
+% ]
+
+%fun createCommonControl
+%    :: CommonControl -> WindowStyle -> String -> WindowStyle
+%    -> MbPos -> MbPos -> MbPos -> MbPos 
+%    -> MbHWND -> MbHMENU -> HANDLE 
+%    -> IO HWND
+%call (commonControl c) (windowStyle estyle) (string nm) (windowStyle wstyle)
+%     (mbPos x) (mbPos y) (mbPos w) (mbPos h) 
+%     (mbHWND parent) (mbHMENU hmenu) (hANDLE handle)
+%code hwnd = CreateWindowEx(estyle, c, nm,wstyle,x,y,w,h,parent,hmenu,handle,NULL);
+%fail { hwnd == NULL } { ErrorWin("CreateCommonControl") }
+%result (hWND hwnd)
+
+%fun InitCommonControls :: IO ()
+
+-}
+
+%const WindowMessage
+% [ PBM_DELTAPOS
+% , PBM_SETPOS
+% , PBM_SETRANGE
+% , PBM_SETSTEP
+% , PBM_STEPIT
+% ]
+
+-- % , PBM_GETRANGE
+-- % , PBM_GETPOS
+-- % , PBM_SETBARCOLOR
+-- % , PBM_SETBKCOLOR
+-- % , PBM_SETRANGE32

System/Win32/DLL.gc

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.
+-- Copyright   :  (c) Alastair Reid, 1997-2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- A collection of GreenCard declarations for interfacing with Win32.
+--
+-----------------------------------------------------------------------------
+
+module System.Win32.DLL where
+
+import System.Win32.StdDIS
+import System.Win32.Types
+
+%#include <windows.h>
+%#include "errors.h"
+%#include "win32debug.h"
+%#include "finalizers.h"
+
+%fun DisableThreadLibraryCalls :: HMODULE -> IO ()
+%code BOOL res1 = DisableThreadLibraryCalls(arg1);
+%fail { res1 == FALSE } { ErrorWin("DisableThreadLibraryCalls")}
+
+%fun FreeLibrary :: HMODULE -> IO ()
+%code BOOL res1 = FreeLibrary(arg1);
+%fail { res1 == FALSE } { ErrorWin("FreeLibrary")}
+
+%fun GetModuleFileName :: HMODULE -> IO String
+%code char* res1; DWORD dw = 1;
+%     if ((res1=malloc(sizeof(char)*512)) == NULL) {
+%        res1=NULL;
+%     } else {
+%        dw = GetModuleFileName(arg1,res1,512);
+%     }
+%fail {res1 == NULL || dw == 0} {ErrorWin("GetModuleFileName")}
+
+%fun GetModuleHandle :: MbString -> IO HMODULE
+%fail {res1 == NULL} {ErrorWin("GetModuleHandle")}
+
+%fun GetProcAddress :: HMODULE -> String -> IO Addr
+%fail {res1 == NULL} {ErrorWin("GetProcAddress")}
+
+%fun LoadLibrary :: String -> IO HINSTANCE
+%fail {res1 == NULL} {ErrorWin("LoadLibrary")}
+
+type LoadLibraryFlags = DWORD
+%dis loadLibraryFlags x = dWORD x
+
+%const LoadLibraryFlags 
+% [ LOAD_LIBRARY_AS_DATAFILE
+% , LOAD_WITH_ALTERED_SEARCH_PATH
+% ]
+
+%fun LoadLibraryEx :: String -> HANDLE -> LoadLibraryFlags -> IO HINSTANCE
+%fail {res1 == NULL} {ErrorWin("LoadLibraryEx")}
+

System/Win32/Dialogue.gc

+{-# OPTIONS -#include "System.Win32.Dialogue_stub.h" #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Dialogue
+-- Copyright   :  (c) Alastair Reid, 1997-2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- A collection of GreenCard declarations for interfacing with Win32.
+--
+-----------------------------------------------------------------------------
+
+module System.Win32.Dialogue where
+
+import System.Win32.StdDIS
+import System.Win32.Types
+import System.Win32.GDITypes
+import System.Win32.Window
+import System.Win32.WinMessage
+import System.Win32.Control
+
+%#include <windows.h>
+%#include "errors.h"
+%#include "win32debug.h"
+%#include "diatemp.h"
+
+type DTemplate = LPCTSTR
+%dis dTemplate x = (lPCTSTR x)
+
+type DTemplateMem = Ptr Stub_DTM
+data Stub_DTM
+%dis dTemplateMem x = (ptr x)
+
+type DialogStyle = WindowStyle
+%dis dialogStyle x = windowStyle x
+
+mkDialogTemplate :: String -> IO DTemplate
+mkDialogTemplate = marshall_string_
+
+type ResourceID = Int
+%dis resourceID x = int x
+
+%fun mkResource :: ResourceID -> IO (Ptr a)
+%code res1=MAKEINTRESOURCE(arg1);
+
+mkDialogTemplateFromResource :: Int -> IO DTemplate
+mkDialogTemplateFromResource = mkResource
+
+type DialogProc = HWND -> WindowMessage -> WPARAM -> LPARAM -> IO Int
+
+%dis dialogProc x = dialogProc_ (funPtr x)
+
+marshall_dialogProc_ :: DialogProc -> IO (FunPtr DialogProc)
+marshall_dialogProc_ cl = mkDialogClosure cl
+
+-- ToDo: this was declared as a stdcall not a ccall - let's
+-- hope and pray that it makes no difference - ADR
+foreign import ccall "wrapper" mkDialogClosure :: DialogProc -> IO (FunPtr DialogProc)
+--marshall_dialogProc_ x = return nullAddr
+
+%fun DialogBox :: HINSTANCE -> DTemplate -> MbHWND -> DialogProc -> IO Int
+%call (hINSTANCE hInst) (dTemplate lpTemp) (mbHWND hWndParent) (dialogProc diaFun)
+%safecode res1 = DialogBox(hInst,lpTemp,hWndParent,diaFun);
+%fail { res1 == (-1) } { ErrorWin("DialogBox") }
+
+%fun DialogBoxParam :: HINSTANCE -> DTemplate -> MbHWND -> DialogProc -> LPARAM -> IO Int
+%call (hINSTANCE hInst) (dTemplate lpTemp) (mbHWND hWndParent) (dialogProc diaFun) (lPARAM dwInit)
+%safecode res1 = DialogBoxParam(hInst,lpTemp,hWndParent,diaFun,dwInit);
+%fail { res1 == (-1) } { ErrorWin("DialogBoxParam") }
+
+%fun DialogBoxIndirect :: HINSTANCE -> DTemplateMem -> MbHWND -> DialogProc -> IO Int
+%call (hINSTANCE hInst) (dTemplateMem lpTemp) (mbHWND hWndParent) (dialogProc diaFun)
+%safecode res1 = DialogBoxIndirect(hInst,lpTemp,hWndParent,diaFun);
+%fail { res1 == (-1) } { ErrorWin("DialogBoxIndirect") }
+
+%fun DialogBoxIndirectParam :: HINSTANCE -> DTemplateMem -> MbHWND -> DialogProc -> LPARAM -> IO Int
+%call (hINSTANCE hInst) (dTemplateMem lpTemp) (mbHWND hWndParent) (dialogProc diaFun) (lPARAM dwInit)
+%safecode res1 = DialogBoxIndirectParam(hInst,lpTemp,hWndParent,diaFun,dwInit);
+%fail { res1 == (-1) } { ErrorWin("DialogBoxIndirectParam") }
+
+
+data DialogTemplate
+ = DialogTemplate 
+      Int Int Int Int  -- x, y, cx, cy
+      WindowStyle
+      DWORD
+      (Either ResourceID String)  -- menu
+      (Either ResourceID String)  -- class
+      (Either ResourceID String)  -- caption
+      (Either ResourceID String)  -- fontname
+      Int	 		  -- font height
+      [DialogControl]
+
+data DialogControl
+ = DialogControl
+      Int Int Int Int -- x,y, cx, cy
+      (Either ResourceID String) -- text
+      (Either ResourceID String) -- classname
+      WindowStyle
+      DWORD
+      Int			 -- id
+
+mkDialogFromTemplate :: DialogTemplate -> IO DTemplateMem
+mkDialogFromTemplate (DialogTemplate x y cx cy
+				     wstyle extstyle
+				     mb_menu mb_class caption
+				     font font_height
+				     controls) = do
+  prim_hmenu    <- marshall_res mb_menu
+  prim_class    <- marshall_res mb_class
+  prim_caption  <- marshall_res caption
+  prim_font     <- marshall_res font
+  dtemp <- mkDiaTemplate 0 x y cx cy wstyle extstyle 
+  			 prim_hmenu prim_class
+			 prim_caption prim_font
+			 font_height
+  mapM_ (addControl dtemp) controls
+  getFinalDialog dtemp
+
+pushButtonControl :: Int -> Int -> Int -> Int
+		  -> DWORD -> DWORD -> Int
+		  -> String
+		  -> DialogControl
+pushButtonControl x y cx cy style estyle id lab =
+  DialogControl x y cx cy (Left 0x0080) (Right lab)
+  		(style + bS_DEFPUSHBUTTON) estyle id
+
+labelControl :: Int -> Int -> Int -> Int
+	     -> DWORD -> DWORD -> Int
+	     -> String
+             -> DialogControl
+labelControl x y cx cy style estyle id lab =
+  DialogControl x y cx cy (Left 0x0082) (Right lab)
+  		(style + sS_LEFT) estyle id
+
+listBoxControl :: Int -> Int -> Int -> Int
+	       -> DWORD -> DWORD -> Int
+	       -> String
+               -> DialogControl
+listBoxControl x y cx cy style estyle id lab =
+  DialogControl x y cx cy (Left 0x0083) (Right lab)
+  		(style) estyle id
+
+comboBoxControl :: Int -> Int -> Int -> Int
+	       -> DWORD -> DWORD -> Int
+	       -> String
+               -> DialogControl
+comboBoxControl x y cx cy style estyle id lab =
+  DialogControl x y cx cy (Left 0x0085) (Right lab)
+  		(style) estyle id
+
+editControl :: Int -> Int -> Int -> Int
+	       -> DWORD -> DWORD -> Int
+	       -> String
+               -> DialogControl
+editControl x y cx cy style estyle id lab =
+  DialogControl x y cx cy (Left 0x0081) (Right lab)
+  		(style + eS_LEFT) estyle id
+
+scrollBarControl :: Int -> Int -> Int -> Int
+	       -> DWORD -> DWORD -> Int
+	       -> String
+               -> DialogControl
+scrollBarControl x y cx cy style estyle id lab =
+  DialogControl x y cx cy (Left 0x0084) (Right lab)
+  		(style) estyle id
+
+%fun getFinalDialog :: Addr -> IO DTemplateMem
+
+%fun mkDiaTemplate :: Int -> Int -> Int -> Int -> Int -> WindowStyle -> DWORD -> Ptr a -> Ptr b -> Ptr c -> Ptr d -> Int -> IO Addr
+
+addControl :: Addr -> DialogControl -> IO ()
+addControl dtemp (DialogControl x y cx cy mb_text mb_class
+				style exstyle
+				id) = do
+   prim_text  <- marshall_res mb_text
+   prim_class <- marshall_res mb_class
+   addDiaControl dtemp prim_text id prim_class style 
+  		 x y cx cy exstyle
+   return ()
+
+%fun addDiaControl :: Addr -> Ptr a -> Int -> Ptr b -> DWORD -> Int -> Int -> Int -> Int -> DWORD -> IO Addr
+
+marshall_res :: Either ResourceID String -> IO (Ptr a)
+marshall_res (Left r)  = mkResource r
+marshall_res (Right s) = toUnicodeStr s
+
+%fun toUnicodeStr :: String -> IO (Ptr a)
+%code int wlen;
+%     LPWSTR wstr;
+%     wlen = MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED,arg1,-1,NULL,0);
+%     wstr = malloc(sizeof(wchar_t) * wlen);
+%     MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED,arg1,-1,wstr,wlen);
+%result (ptr {wstr})
+
+-- modeless dialogs
+%fun CreateDialog :: HINSTANCE -> DTemplate -> MbHWND -> DialogProc -> IO HWND
+%call (hINSTANCE hInst) (dTemplate lpTemp) (mbHWND hWndParent) (dialogProc diaFun)
+%safecode res1 = CreateDialog(hInst,lpTemp,hWndParent,diaFun);
+%fail { res1 == NULL } { ErrorWin("CreateDialog") }
+
+%fun CreateDialogParam :: HINSTANCE -> DTemplate -> MbHWND -> DialogProc -> LPARAM -> IO HWND
+%call (hINSTANCE hInst) (dTemplate lpTemp) (mbHWND hWndParent) (dialogProc diaFun) (lPARAM dwInit)
+%safecode res1 = CreateDialogParam(hInst,lpTemp,hWndParent,diaFun,dwInit);
+%fail { res1 == NULL } { ErrorWin("CreateDialogParam") }
+
+%fun CreateDialogIndirect :: HINSTANCE -> DTemplateMem -> MbHWND -> DialogProc -> IO HWND
+%call (hINSTANCE hInst) (dTemplateMem lpTemp) (mbHWND hWndParent) (dialogProc diaFun)
+%safecode res1 = CreateDialogIndirect(hInst,lpTemp,hWndParent,diaFun);
+%fail { res1 == NULL } { ErrorWin("CreateDialogIndirect") }
+
+%fun CreateDialogIndirectParam :: HINSTANCE -> DTemplateMem -> MbHWND -> DialogProc -> LPARAM -> IO HWND
+%call (hINSTANCE hInst) (dTemplateMem lpTemp) (mbHWND hWndParent) (dialogProc diaFun) (lPARAM dwInit)
+%safecode res1 = CreateDialogIndirectParam(hInst,lpTemp,hWndParent,diaFun,dwInit);
+%fail { res1 == NULL } { ErrorWin("CreateDialogIndirectParam") }
+
+%fun DefDlgProc :: MbHWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT
+%safecode res1 = DefDlgProc(arg1,arg2,arg3,arg4);
+
+%fun EndDialog :: HWND -> Int -> IO BOOL
+%safecode res1 = EndDialog(arg1,arg2);
+%fail { res1 == 0 } { ErrorWin("EndDialog") }
+
+%fun GetDialogBaseUnits :: IO LONG
+
+%fun GetDlgCtrlID :: HWND -> IO Int
+%fail { res1 == 0 } { ErrorWin("GetDlgCtrlID") }
+
+%fun GetDlgItem :: HWND -> Int -> IO HWND
+%fail { res1 == NULL } { ErrorWin("GetDlgItem") }
+
+%fun GetDlgItemInt :: HWND -> Int -> Bool -> IO Int
+%safecode BOOL lpTranslated;
+%         res1 = GetDlgItemInt(arg1,arg2,&lpTranslated,arg3);
+%fail { lpTranslated != TRUE } { ErrorWin("GetDlgItemInt") }
+
+%fun GetDlgItemText :: HWND -> Int -> Int -> IO String
+%safecode LPTSTR buf=malloc(sizeof(TCHAR)*arg3); int res1;
+%         if (buf == NULL) { 
+%            res1 = 0;
+%         } else {
+%            res1 = GetDlgItemText(arg1,arg2,buf,arg3);
+%        }
+%fail { res1 == 0 } { ErrorWin("GetDlgItemInt") }
+%result (string {buf})
+
+%fun GetNextDlgGroupItem :: HWND -> HWND -> BOOL -> IO HWND
+%fail { res1 == NULL } { ErrorWin("GetNextDlgGroupItem") }
+
+%fun GetNextDlgTabItem :: HWND -> HWND -> BOOL -> IO HWND
+%fail { res1 == NULL } { ErrorWin("GetNextDlgTabItem") }
+
+%fun IsDialogMessage :: HWND -> LPMSG -> IO BOOL
+%safecode res1=IsDialogMessage(arg1,arg2);
+
+%fun MapDialogRect :: HWND -> LPRECT -> IO ()
+%code BOOL res1; 
+%     res1 = MapDialogRect(arg1,arg2);
+%fail { res1 == 0 } { ErrorWin("MapDialogRect") }
+
+-- No MessageBox* funs in here just yet.
+
+%fun SendDlgItemMessage :: HWND -> Int -> WindowMessage -> WPARAM -> LPARAM -> IO LONG
+%safecode res1 = SendDlgItemMessage(arg1,arg2,arg3,arg4,arg5);
+
+%fun SetDlgItemInt :: HWND -> Int -> UINT -> BOOL -> IO ()
+%code BOOL res1;
+%     res1=SetDlgItemInt(arg1,arg2,arg3,arg4);
+%fail { res1 == 0 } { ErrorWin("SetDlgItemInt") }
+
+%fun SetDlgItemText :: HWND -> Int -> String -> IO ()
+%safecode BOOL res1;
+%         res1 = SetDlgItemText(arg1,arg2,arg3);
+%fail { res1 == 0 } { ErrorWin("SetDlgItemText") }
+
+%const WindowStyle 
+%  [ DS_3DLOOK
+%  , DS_ABSALIGN
+%  , DS_CENTER
+%  , DS_CENTERMOUSE
+%  , DS_CONTEXTHELP
+%  , DS_CONTROL
+%  , DS_FIXEDSYS
+%  , DS_LOCALEDIT
+%  , DS_MODALFRAME
+%  , DS_NOFAILCREATE
+%  , DS_NOIDLEMSG
+%  , DS_SETFONT
+%  , DS_SETFOREGROUND
+%  , DS_SYSMODAL
+%  ]
+
+%const WindowMessage
+%  [ DM_GETDEFID
+%  , DM_REPOSITION
+%  , DM_SETDEFID
+%  , WM_CTLCOLORDLG
+%  , WM_CTLCOLORMSGBOX
+%  ]
+
+----------------------------------------------------------------
+-- End
+----------------------------------------------------------------

System/Win32/File.gc

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.File
+-- Copyright   :  (c) Alastair Reid, 1997-2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- A collection of GreenCard declarations for interfacing with Win32.
+--
+-----------------------------------------------------------------------------
+
+module System.Win32.File
+{-
+	( AccessMode, ShareMode, CreateMode, FileAttributeOrFlag
+	, CreateFile, CloseHandle, DeleteFile, CopyFile
+	, MoveFileFlag, MoveFile, MoveFileEx, 
+	)
+-}
+where
+
+import System.Win32.Types
+import System.Win32.StdDIS
+
+%#include <windows.h>
+%#include "errors.h"
+%#include "win32debug.h"
+%#include "finalizers.h"
+
+----------------------------------------------------------------
+-- Enumeration types
+----------------------------------------------------------------
+
+%dis accessMode x = uINT x
+type AccessMode   = UINT
+
+%const AccessMode
+% [ gENERIC_NONE = { 0 }
+% , GENERIC_READ
+% , GENERIC_WRITE
+% , GENERIC_EXECUTE
+% , GENERIC_ALL
+% , DELETE
+% , READ_CONTROL
+% , WRITE_DAC
+% , WRITE_OWNER
+% , SYNCHRONIZE
+% , STANDARD_RIGHTS_REQUIRED
+% , STANDARD_RIGHTS_READ
+% , STANDARD_RIGHTS_WRITE
+% , STANDARD_RIGHTS_EXECUTE
+% , STANDARD_RIGHTS_ALL
+% , SPECIFIC_RIGHTS_ALL
+% , ACCESS_SYSTEM_SECURITY
+% , MAXIMUM_ALLOWED
+% ]
+
+----------------------------------------------------------------
+
+%dis shareMode x = uINT x
+type ShareMode   = UINT
+
+%const ShareMode
+% [ fILE_SHARE_NONE = { 0 }
+% , FILE_SHARE_READ
+% , FILE_SHARE_WRITE
+% ]
+
+----------------------------------------------------------------
+
+%dis createMode x = uINT x
+type CreateMode   = UINT
+
+%const CreateMode 
+% [ CREATE_NEW
+% , CREATE_ALWAYS
+% , OPEN_EXISTING
+% , OPEN_ALWAYS
+% , TRUNCATE_EXISTING
+% ]
+
+----------------------------------------------------------------
+
+%dis fileAttributeOrFlag x = uINT x
+type FileAttributeOrFlag   = UINT
+
+%const FileAttributeOrFlag 
+% [ FILE_ATTRIBUTE_READONLY
+% , FILE_ATTRIBUTE_HIDDEN
+% , FILE_ATTRIBUTE_SYSTEM
+% , FILE_ATTRIBUTE_DIRECTORY
+% , FILE_ATTRIBUTE_ARCHIVE
+% , FILE_ATTRIBUTE_NORMAL
+% , FILE_ATTRIBUTE_TEMPORARY
+% , FILE_ATTRIBUTE_COMPRESSED
+% , FILE_FLAG_WRITE_THROUGH
+% , FILE_FLAG_OVERLAPPED
+% , FILE_FLAG_NO_BUFFERING
+% , FILE_FLAG_RANDOM_ACCESS
+% , FILE_FLAG_SEQUENTIAL_SCAN
+% , FILE_FLAG_DELETE_ON_CLOSE
+% , FILE_FLAG_BACKUP_SEMANTICS
+% , FILE_FLAG_POSIX_SEMANTICS
+% , SECURITY_ANONYMOUS
+% , SECURITY_IDENTIFICATION
+% , SECURITY_IMPERSONATION
+% , SECURITY_DELEGATION
+% , SECURITY_CONTEXT_TRACKING
+% , SECURITY_EFFECTIVE_ONLY
+% , SECURITY_SQOS_PRESENT
+% , SECURITY_VALID_SQOS_FLAGS
+% ]
+
+----------------------------------------------------------------
+
+%dis moveFileFlag x = dWORD x
+type MoveFileFlag   = DWORD
+
+%const MoveFileFlag
+% [ MOVEFILE_REPLACE_EXISTING
+% , MOVEFILE_COPY_ALLOWED
+% , MOVEFILE_DELAY_UNTIL_REBOOT
+% ]
+
+----------------------------------------------------------------
+
+%dis filePtrDirection x = dWORD x
+type FilePtrDirection   = DWORD
+
+%const FilePtrDirection
+% [ FILE_BEGIN
+% , FILE_CURRENT
+% , FILE_END
+% ]
+
+----------------------------------------------------------------
+
+%dis driveType x = uINT x
+type DriveType = UINT
+
+%const DriveType 
+% [ DRIVE_UNKNOWN
+% , DRIVE_NO_ROOT_DIR
+% , DRIVE_REMOVABLE
+% , DRIVE_FIXED
+% , DRIVE_REMOTE
+% , DRIVE_CDROM
+% , DRIVE_RAMDISK
+% ]
+
+----------------------------------------------------------------
+
+%dis defineDosDeviceFlags x = dWORD x
+type DefineDosDeviceFlags = DWORD
+
+%const DefineDosDeviceFlags 
+% [ DDD_RAW_TARGET_PATH
+% , DDD_REMOVE_DEFINITION
+% , DDD_EXACT_MATCH_ON_REMOVE
+% ]
+
+----------------------------------------------------------------
+
+%dis binaryType x = dWORD x
+type BinaryType = DWORD
+
+%const BinaryType 
+% [ SCS_32BIT_BINARY
+% , SCS_DOS_BINARY
+% , SCS_WOW_BINARY
+% , SCS_PIF_BINARY
+% , SCS_POSIX_BINARY
+% , SCS_OS216_BINARY
+% ]
+
+----------------------------------------------------------------
+
+%dis fileNotificationFlag x= dWORD x
+type FileNotificationFlag = DWORD
+
+%const FileNotificationFlag 
+% [ FILE_NOTIFY_CHANGE_FILE_NAME
+% , FILE_NOTIFY_CHANGE_DIR_NAME
+% , FILE_NOTIFY_CHANGE_ATTRIBUTES
+% , FILE_NOTIFY_CHANGE_SIZE
+% , FILE_NOTIFY_CHANGE_LAST_WRITE
+% , FILE_NOTIFY_CHANGE_SECURITY
+% ]
+
+----------------------------------------------------------------
+
+%dis fileType x = dWORD x
+type FileType = DWORD
+
+%const FileType
+% [ FILE_TYPE_UNKNOWN
+% , FILE_TYPE_DISK
+% , FILE_TYPE_CHAR
+% , FILE_TYPE_PIPE
+% , FILE_TYPE_REMOTE
+% ]
+
+----------------------------------------------------------------
+
+type LPSECURITY_ATTRIBUTES = Addr
+%dis mbLPSECURITY_ATTRIBUTES x = maybeT {nullAddr} (addr x)
+type MbLPSECURITY_ATTRIBUTES = Maybe LPSECURITY_ATTRIBUTES
+
+----------------------------------------------------------------
+-- File operations
+----------------------------------------------------------------
+
+%fun DeleteFile :: String -> IO ()
+%code BOOL success = DeleteFile(arg1);
+%fail { !success } { ErrorWin("DeleteFile") }
+%end free(arg1)
+
+%fun CopyFile :: String -> String -> Bool -> IO ()
+%code BOOL success = CopyFile(arg1, arg2, arg3);
+%fail { !success } { ErrorWin("CopyFile") }
+%end free(arg1); free(arg2)
+
+%fun MoveFile   :: String -> String -> IO ()
+%code BOOL success = MoveFile(arg1, arg2);
+%fail { !success } { ErrorWin("MoveFile") }
+%end free(arg1); free(arg2)
+
+%fun MoveFileEx :: String -> String -> MoveFileFlag -> IO ()
+%code BOOL success = MoveFileEx(arg1, arg2, arg3);
+%fail { !success } { ErrorWin("MoveFileEx") }
+%end free(arg1); free(arg2)
+
+%fun SetCurrentDirectory :: String -> IO ()
+%code BOOL success = SetCurrentDirectory(arg1);
+%fail { !success } { ErrorWin("SetCurrentDirectory") }
+%end free(arg1)
+
+%fun CreateDirectory :: String -> MbLPSECURITY_ATTRIBUTES -> IO ()
+%code BOOL success = CreateDirectory(arg1, arg2);
+%fail { !success } { ErrorWin("CreateDirecotry") }
+%end free(arg1)
+
+%fun CreateDirectoryEx :: String -> String -> MbLPSECURITY_ATTRIBUTES -> IO ()
+%code BOOL success = CreateDirectoryEx(arg1, arg2, arg3);
+%fail { !success } { ErrorWin("CreateDirectoryEx") }
+%end free(arg1); free(arg2)
+
+%fun RemoveDirectory :: String -> IO ()
+%code BOOL success = RemoveDirectory(arg1);
+%fail { !success } { ErrorWin("RemoveDirecotry") }
+%end free(arg1)
+
+%fun getBinaryType :: String -> IO BinaryType
+%code BOOL success = GetBinaryType(arg1,&res1);
+%fail { !success } { ErrorString("GetBinaryType") }
+%end free(arg1)
+
+----------------------------------------------------------------
+-- HANDLE operations
+----------------------------------------------------------------
+
+%fun CreateFile :: String -> AccessMode -> ShareMode -> MbLPSECURITY_ATTRIBUTES -> CreateMode -> FileAttributeOrFlag -> MbHANDLE -> IO HANDLE
+%fail { res1 == 0 } { ErrorWin("CreateFile") }
+%end free(arg1)
+
+%fun CloseHandle :: HANDLE -> IO ()
+%code BOOL success = CloseHandle(arg1);
+%fail { !success } { ErrorWin("CloseHandle") }
+
+%fun GetFileType :: HANDLE -> IO FileType
+--Apparently no error code
+
+%fun FlushFileBuffers :: HANDLE -> IO ()
+%code BOOL success = FlushFileBuffers(arg1)
+%fail {!success} { ErrorWin("FlushFileBuffers") }
+
+%fun SetEndOfFile :: HANDLE -> IO ()
+%code BOOL success = SetEndOfFile(arg1)
+%fail {!success} { ErrorWin("SetEndOfFile") }
+
+%fun SetFileAttributes :: String -> FileAttributeOrFlag -> IO ()
+%code BOOL success = SetFileAttributes(arg1,arg2)
+%fail {!success} { ErrorWin("SetFileAttributes") }
+%end free(arg1)
+
+%fun GetFileAttributes :: String -> IO FileAttributeOrFlag
+%code res1=GetFileAttributes(arg1)
+%fail {res1 == 0xFFFFFFFF} { ErrorWin("GetFileAttributes") }
+%end free(arg1)
+
+----------------------------------------------------------------
+-- Read/write files
+----------------------------------------------------------------
+
+-- No support for this yet
+--type OVERLAPPED =
+-- (DWORD,  -- Offset
+--  DWORD,  -- OffsetHigh
+--  HANDLE) -- hEvent
+
+%dis lPOVERLAPPED x = addr ({LPOVERLAPPED} x)
+type LPOVERLAPPED = Addr
+
+%dis mbLPOVERLAPPED x = maybeT {nullAddr} (lPOVERLAPPED x)
+type MbLPOVERLAPPED = Maybe LPOVERLAPPED
+
+--Sigh - I give up & prefix win32_ to the next two to avoid
+-- senseless Prelude name clashes. --sof.
+
+%fun win32_ReadFile :: HANDLE -> Addr -> DWORD -> MbLPOVERLAPPED -> IO DWORD
+%code BOOL success = ReadFile(arg1,arg2,arg3,&res1,arg4);
+%fail { !success } { ErrorString("ReadFile") }
+
+%fun win32_WriteFile :: HANDLE -> Addr -> DWORD -> MbLPOVERLAPPED -> IO DWORD
+%code  BOOL success = WriteFile(arg1,arg2,arg3,&res1,arg4);
+%fail { !success } { ErrorString("WriteFile") }
+
+-- missing Seek functioinality; GSL ???
+-- Dont have Word64; ADR
+-- %fun SetFilePointer :: HANDLE -> Word64 -> FilePtrDirection -> IO Word64
+
+----------------------------------------------------------------
+-- File Notifications
+--
+-- Use these to initialise, "increment" and close a HANDLE you can wait
+-- on.
+----------------------------------------------------------------
+
+%fun FindFirstChangeNotification :: String -> Bool -> FileNotificationFlag -> IO HANDLE
+%fail { res1 == 0 } { ErrorString("FindFirstChangeNotification") }
+%end free(arg1)
+
+%fun FindNextChangeNotification  :: HANDLE -> IO ()
+%code BOOL success = FindNextChangeNotification(arg1);
+%fail { !success } { ErrorWin("FindNextChangeNotification") }
+
+%fun FindCloseChangeNotification :: HANDLE -> IO ()
+%code BOOL success = FindCloseChangeNotification(arg1);
+%fail { !success } { ErrorWin("FindCloseChangeNotification") }
+
+----------------------------------------------------------------
+-- DOS Device flags
+----------------------------------------------------------------
+
+%fun DefineDosDevice :: DefineDosDeviceFlags -> String -> String -> IO ()
+%code BOOL success = DefineDosDevice(arg1, arg2, arg3);
+%fail { !success } { ErrorWin("DefineDosDevice") }
+%end free(arg2); free(arg3)
+
+----------------------------------------------------------------
+
+-- These functions are very unusual in the Win32 API:
+-- They dont return error codes
+
+%fun AreFileApisANSI   :: IO Bool
+%fun SetFileApisToOEM  :: IO ()
+%fun SetFileApisToANSI :: IO ()
+%fun SetHandleCount    :: UINT -> IO UINT
+
+----------------------------------------------------------------
+
+%fun GetLogicalDrives :: IO DWORD
+%fail { res1 == 0 } { ErrorString("GetLogicalDrives") }
+
+-- %fun GetDriveType :: MbString -> IO DriveType
+
+%fun GetDiskFreeSpace :: MbString -> IO (DWORD,DWORD,DWORD,DWORD)
+%call (mbString s)
+%code BOOL success = GetDiskFreeSpace(s,&res1,&res2,&res3,&res4)
+%fail { !success} { ErrorWin("GetDiskFreeSpace") }
+%end if (s) { free(s); }
+
+%fun SetVolumeLabel :: String -> String -> IO ()
+%code BOOL success = SetVolumeLabel(arg1, arg2);
+%fail { !success } { ErrorWin("SetVolumeLabel") }
+%end free(arg1); free(arg2)
+
+----------------------------------------------------------------
+-- End
+----------------------------------------------------------------

System/Win32/Font.gc

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Font
+-- Copyright   :  (c) Alastair Reid, 1997-2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- A collection of GreenCard declarations for interfacing with Win32.
+--
+-----------------------------------------------------------------------------
+
+module System.Win32.Font
+{-
+	( CharSet
+	, PitchAndFamily
+	, OutPrecision
+	, ClipPrecision
+	, FontQuality
+	, FontWeight
+
+	, createFont, deleteFont
+
+	, StockFont, getStockFont
+	, oEM_FIXED_FONT, aNSI_FIXED_FONT, aNSI_VAR_FONT, sYSTEM_FONT
+	, dEVICE_DEFAULT_FONT, sYSTEM_FIXED_FONT
+	) where
+-}
+	where
+
+import System.Win32.StdDIS
+import System.Win32.Types
+import System.Win32.GDITypes
+
+%#include <windows.h>
+%#include "errors.h"
+%#include "win32debug.h"
+
+----------------------------------------------------------------
+-- Types
+----------------------------------------------------------------
+
+type CharSet        = UINT
+type PitchAndFamily = UINT
+type OutPrecision   = UINT
+type ClipPrecision  = UINT
+type FontQuality    = UINT
+type FontWeight     = Word32
+type FaceName       = String
+
+%dis hFONT          x = addr ({HFONT} x)
+%dis charSet        x = uINT x
+%dis pitchAndFamily x = uINT x
+%dis outPrecision   x = uINT x
+%dis clipPrecision  x = uINT x
+%dis fontQuality    x = uINT x
+%dis fontWeight     x = word32 x
+%dis faceName       x = string x
+
+-- A FaceName is a string no more that LF_FACESIZE in length
+-- (including null terminator).
+-- %const Int LF_FACESIZE         # == 32
+-- %sentinel_array : FaceName : CHAR : char : $0 = '\0' : ('\0' == $0) : LF_FACESIZE
+
+----------------------------------------------------------------
+-- Constants
+----------------------------------------------------------------
+
+%const CharSet 
+% [ ANSI_CHARSET
+% , DEFAULT_CHARSET
+% , SYMBOL_CHARSET
+% , SHIFTJIS_CHARSET
+% , HANGEUL_CHARSET
+% , CHINESEBIG5_CHARSET
+% , OEM_CHARSET
+% ]
+
+%const PitchAndFamily
+% [ DEFAULT_PITCH
+% , FIXED_PITCH
+% , VARIABLE_PITCH
+% , FF_DONTCARE
+% , FF_ROMAN
+% , FF_SWISS
+% , FF_MODERN
+% , FF_SCRIPT
+% , FF_DECORATIVE
+% , familyMask = { 0xF0 }
+% , pitchMask = { 0x0F }
+% ]
+
+%const OutPrecision 
+% [ OUT_DEFAULT_PRECIS
+% , OUT_STRING_PRECIS
+% , OUT_CHARACTER_PRECIS
+% , OUT_STROKE_PRECIS
+% , OUT_TT_PRECIS
+% , OUT_DEVICE_PRECIS
+% , OUT_RASTER_PRECIS
+% , OUT_TT_ONLY_PRECIS
+% ]
+
+%const ClipPrecision 
+% [ CLIP_DEFAULT_PRECIS
+% , CLIP_CHARACTER_PRECIS
+% , CLIP_STROKE_PRECIS
+% , CLIP_MASK
+% , CLIP_LH_ANGLES
+% , CLIP_TT_ALWAYS
+% , CLIP_EMBEDDED
+% ]
+
+%const FontQuality [DEFAULT_QUALITY,DRAFT_QUALITY,PROOF_QUALITY]
+
+%const FontWeight 
+% [ FW_DONTCARE
+% , FW_THIN
+% , FW_EXTRALIGHT
+% , FW_LIGHT
+% , FW_NORMAL
+% , FW_MEDIUM
+% , FW_SEMIBOLD
+% , FW_BOLD
+% , FW_EXTRABOLD
+% , FW_HEAVY
+% , FW_REGULAR
+% , FW_ULTRALIGHT
+% , FW_DEMIBOLD
+% , FW_ULTRABOLD
+% , FW_BLACK
+% ]
+
+----------------------------------------------------------------
+-- Functions
+----------------------------------------------------------------
+
+%fun CreateFont 
+%    :: INT -> INT -> INT -> INT 
+%    -> FontWeight -> Bool -> Bool -> Bool 
+%    -> CharSet -> OutPrecision -> ClipPrecision 
+%    -> FontQuality -> PitchAndFamily -> FaceName
+%    -> IO HFONT
+%fail { res1 == 0 } {ErrorMsg("CreateFont","NullHandle")}
+%end free(arg14)
+
+-- test :: IO ()
+-- test = do
+--   f <- createFont_adr (100,100) 0 False False "Arial"
+--   putStrLn "Created first font"
+--   f <- createFont_adr (100,100) (-90) False False "Bogus"
+--   putStrLn "Created second font"
+-- 
+-- createFont_adr (width, height) escapement bold italic family = 
+--  createFont height width
+-- 		     (round (escapement * 1800/pi))
+-- 		     0                     -- orientation
+-- 		     weight
+-- 		     italic False False    -- italic, underline, strikeout
+-- 		     aNSI_CHARSET
+-- 		     oUT_DEFAULT_PRECIS
+-- 		     cLIP_DEFAULT_PRECIS
+-- 		     dEFAULT_QUALITY
+-- 		     dEFAULT_PITCH
+-- 		     family
+--  where
+--   weight | bold      = fW_BOLD
+-- 	    | otherwise = fW_NORMAL
+
+
+-- missing CreateFontIndirect from WinFonts.ss; GSL ???
+
+%fun deleteFont :: HFONT -> IO ()
+%code DeleteObject(arg1);
+
+----------------------------------------------------------------
+
+type StockFont      = WORD
+%dis stockFont x    = wORD x
+
+%const StockFont 
+% [ OEM_FIXED_FONT
+% , ANSI_FIXED_FONT
+% , ANSI_VAR_FONT
+% , SYSTEM_FONT
+% , DEVICE_DEFAULT_FONT
+% , SYSTEM_FIXED_FONT
+% ]
+
+%fun GetStockFont :: StockFont -> IO HFONT
+%code res1 = GetStockObject(arg1);
+
+----------------------------------------------------------------
+-- End
+----------------------------------------------------------------

System/Win32/GDITypes.gc

+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.GDITypes
+-- Copyright   :  (c) Alastair Reid, 1997-2003
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- A collection of GreenCard declarations for interfacing with Win32.
+--
+-----------------------------------------------------------------------------
+
+module System.Win32.GDITypes
+{-  -- still incomplete
+	( POINT,        marshall_point, unmarshall_point
+	, ListPOINT,    marshall_ListPOINT_
+	, ListLenPOINT, marshall_ListLenPOINT_
+	, RECT,         marshall_rect, unmarshall_rect
+	, SIZE,         marshall_size, unmarshall_size
+	, nullAddr
+	, HBITMAP	, MbHBITMAP
+	, HFONT		, MbHFONT
+	, HCURSOR	, MbHCURSOR
+	, HICON		, MbHICON
+	, HRGN		, MbHRGN
+	, HPALETTE	, MbHPALETTE
+	, HBRUSH	, MbHBRUSH
+	, HPEN		, MbHPEN
+	, HACCEL	--, MbHACCEL
+	, HDC		, MbHDC
+	, HDWP          , MbHDWP
+	, HWND		, MbHWND
+	, HMENU		, MbHMENU
+	, PolyFillMode
+	, ArcDirection
+	, MbArcDirection
+	, GraphicsMode
+	, MbGraphicsMode
+	, BackgroundMode
+	, HatchStyle
+	, StretchBltMode
+	, COLORREF
+	, TextAlignment
+	, ClippingMode
+	, RegionType
+	)
+-}
+	where
+
+import System.Win32.StdDIS
+import System.Win32.Types
+import Monad( zipWithM_ )
+import Foreign
+import Int
+import Word
+
+%#include <windows.h>
+%#include "errors.h"
+%#include "win32debug.h"
+%#include "finalizers.h"
+
+----------------------------------------------------------------
+--
+----------------------------------------------------------------
+
+type POINT =
+  ( LONG  -- x
+  , LONG  -- y
+  )
+type RECT =
+  ( LONG  -- left
+  , LONG  -- top
+  , LONG  -- right
+  , LONG  -- bottom
+  )
+type SIZE =
+  ( LONG  -- cx
+  , LONG  -- cy
+  )
+
+%dis point p = (lONG {(%p).x},    lONG {(%p).y})
+%dis rect  r = (lONG {(%r).left}, lONG {(%r).top}, lONG {(%r).right}, lONG {(%r).bottom})
+%dis size  s = (lONG {(%s).cx},   lONG {(%s).cy})
+
+----------------------------------------------------------------
+
+%dis listPOINT x      = listPOINT_    (addr ({POINT *} x))
+%dis listLenPOINT x l = listLenPOINT_ (addr ({POINT *} x), int l)
+
+marshall_listPOINT_ :: [POINT] -> IO Addr
+marshall_listPOINT_ cs = do
+  let l = length cs
+  ps <- mallocPOINTs l
+  zipWithM_ (setPOINT ps) [0..] cs
+  return ps
+
+marshall_listLenPOINT_ :: [POINT] -> IO (Addr, Int)
+marshall_listLenPOINT_ cs = do
+  let l = length cs
+  ps <- mallocPOINTs l
+  zipWithM_ (setPOINT ps) [0..] cs
+  return (ps,l)
+  
+%fun mallocPOINTs :: Int -> IO Addr
+%code ps = (POINT*) malloc(arg1 * sizeof(POINT));
+%fail {ps==0} { MallocError("mallocPOINTs") }
+%result (addr ({POINT*} ps))
+
+%fun setPOINT :: Addr -> Int -> POINT -> IO ()
+%call (addr ({POINT*} ps)) (int i) (point {ps[i]})
+%code
+
+%dis   lPRECT x = addr ({LPRECT} x)
+type   LPRECT   = Addr
+type MbLPRECT   = Maybe LPRECT
+%dis mbLPRECT x = maybeT {nullAddr} (lPRECT x)
+
+%fun getRECT :: LPRECT -> IO RECT
+%call (addr ({RECT*} r))
+%code
+%result (rect {*r})
+
+----------------------------------------------------------------
+-- (GDI related) Handles
+----------------------------------------------------------------
+
+type   HBITMAP    = Addr
+%dis   hBITMAP  x = addr ({HBITMAP} x)
+type MbHBITMAP    = Maybe HBITMAP
+%dis mbHBITMAP  x = maybeT {nullHANDLE} (hBITMAP x)
+
+type   HFONT      = Addr
+%dis   hFONT    x = addr ({HFONT} x)
+type MbHFONT      = Maybe HFONT
+%dis mbHFONT    x = maybeT {nullHANDLE} (hFONT x)
+
+type   HCURSOR    = Addr
+%dis   hCURSOR  x = addr ({HCURSOR} x)
+type MbHCURSOR    = Maybe HCURSOR
+%dis mbHCURSOR  x = maybeT {nullHANDLE} (hCURSOR x)
+
+type   HICON      = Addr
+%dis   hICON    x = addr ({HICON} x)
+type MbHICON      = Maybe HICON
+%dis mbHICON    x = maybeT {nullHANDLE} (hICON x)
+
+
+-- This is not the only handle / resource that should be
+-- finalised for you, but it's a start.
+-- ToDo.
+
+type   HRGN       = ForeignPtr Stub_RGN
+data Stub_RGN
+%dis   hRGN     x = %ForeignPtr {HRGN} x {deleteObj}
+type MbHRGN       = Maybe HRGN
+%dis mbHRGN     x = maybeT {nullPtr} (hRGN x)
+
+type   HPALETTE   = Addr
+%dis   hPALETTE x = addr ({HPALETTE} x)
+type MbHPALETTE   = Maybe HPALETTE
+%dis mbHPALETTE x = maybeT {nullHANDLE} (hPALETTE x)
+
+type   HBRUSH     = Addr
+%dis   hBRUSH   x = addr ({HBRUSH} x)
+type MbHBRUSH     = Maybe HBRUSH
+%dis mbHBRUSH   x = maybeT {nullHANDLE} (hBRUSH x)
+
+type   HPEN       = Addr
+%dis   hPEN     x = addr ({HPEN} x)
+type MbHPEN       = Maybe HPEN
+%dis mbHPEN     x = maybeT {nullHANDLE} (hPEN x)
+
+type   HACCEL     = Addr
+%dis   hACCEL   x = addr ({HACCEL} x)
+
+type   HDC        = Addr
+%dis   hDC      x = addr ({HDC} x)
+type MbHDC        = Maybe HDC
+%dis mbHDC      x = maybeT {nullHANDLE} (hDC x)
+
+type   HDWP        = Addr
+%dis   hDWP     x  = addr ({HDWP} x)
+type MbHDWP        = Maybe HDWP
+%dis mbHDWP      x = maybeT {nullHANDLE} (