Commits

reid  committed 387108a

[project @ 2003-05-28 19:35:36 by reid]
Many of the changes required to make hierarchial win32 package work with latest greencard

  • Participants
  • Parent commits 2d36a0c

Comments (0)

Files changed (33)

 # -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.2 2003/05/17 00:53:51 ross Exp $
+# $Id: Makefile,v 1.3 2003/05/28 19:35:36 reid Exp $
 
-TOP = ..
+TOP = .
 include $(TOP)/mk/boilerplate.mk
 
 # -----------------------------------------------------------------------------
 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_HC_OPTS += -Wall -fffi -cpp -fglasgow-exts
 
 SRC_HADDOCK_OPTS += -t "Win32 Libraries (Win32 package)"
 

File 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
-----------------------------------------------------------------
-
-
+-----------------------------------------------------------------------------
+-- |
+-- 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 Foreign.GreenCard
+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 = ptr ({BITMAP *} x)
+type LPBITMAP = Ptr ()
+
+%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 = Ptr
+%dis lPBITMAPINFO x = ptr ({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 = ptr ({BITMAPINFOHEADER *} x)
+type LPBITMAPINFOHEADER   = Ptr ()
+
+%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 = Ptr ()
+%dis lPBITMAPFILEHEADER x = ptr ({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
+----------------------------------------------------------------
+
+

File 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
-----------------------------------------------------------------
-
+-----------------------------------------------------------------------------
+-- |
+-- 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 Foreign.GreenCard
+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
+----------------------------------------------------------------
+

File 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")}
-
-
-
-
-
-
-
+-----------------------------------------------------------------------------
+-- |
+-- 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 Foreign.GreenCard
+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 -> Ptr () -> 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 :: Ptr () -> 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")}
+
+
+
+
+
+
+

File 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
+-----------------------------------------------------------------------------
+-- |
+-- 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 Foreign.GreenCard
+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   = Ptr ()
+%dis commonControl x = ptr ({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

File System/Win32/DLL.gc

------------------------------------------------------------------------------
--- |
--- Module      :  System.Win32.DLL
--- 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")}
-
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.DLL
+-- 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 Foreign.GreenCard
+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 (Ptr ())
+%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")}
+

File 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);