Commits

Anonymous committed 8f30d1b

[project @ 2003-05-28 20:21:13 by reid]
More changes bringing us closer to building

  • Participants
  • Parent commits 387108a

Comments (0)

Files changed (13)

 # -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.3 2003/05/28 19:35:36 reid Exp $
+# $Id: Makefile,v 1.4 2003/05/28 20:21:13 reid Exp $
 
 TOP = .
 include $(TOP)/mk/boilerplate.mk
 # -----------------------------------------------------------------------------
 
 # Comment out if you want to do initial debugging on Unix systems
-SUBDIRS = cbits
+# SUBDIRS = cbits
 
 ALL_DIRS = \
 	System \
 	System/Win32 
 
 PACKAGE = Win32
-PACKAGE_DEPS = base
+PACKAGE_DEPS = base greencard
 
-SRC_CC_OPTS += -Wall -I../include -I.
-SRC_HC_OPTS += -Wall -fffi -cpp -fglasgow-exts
+SRC_CC_OPTS += -Wall -Iinclude -I.
+SRC_HC_OPTS += -Wall -cpp -fglasgow-exts -fffi
+SRC_HC_OPTS += -package greencard
 
 SRC_HADDOCK_OPTS += -t "Win32 Libraries (Win32 package)"
 
 
 # -----------------------------------------------------------------------------
 
-# 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
 
-# -----------------------------------------------------------------------------
+yyy : $(HS_OBJS) $(DERIVED_SRCS)
 
-include $(TOP)/mk/target.mk

System/Win32/Bitmap.gc

 ----------------------------------------------------------------
 
 -- Yoiks - name clash
--- %dis bitmap x = addr ({LPTSTR} x)
+-- %dis bitmap x = ptr ({LPTSTR} x)
 -- 
 -- type Bitmap = LPCTSTR
 -- 

System/Win32/Clip.gc

 %fun GetClipboardData :: ClipboardFormat -> IO HANDLE
 %fail {res1==NULL}{ErrorWin("GetClipboardData")}
 
-%fun GetClipboardFormatName :: ClipboardFormat -> Ptr () -> Int -> IO Int
+%fun GetClipboardFormatName :: ClipboardFormat -> Addr -> Int -> IO Int
 %fail {res1==0}{ErrorWin("GetClipboardFormatName")}
 
 %fun GetClipboardOwner :: IO HWND
 %fun GetOpenClipboardWindow :: IO HWND
 %fail {res1==NULL}{ErrorWin("GetClipboardWindow")}
 
-%fun GetPriorityClipboardFormat :: Ptr () -> Int -> IO Int
+%fun GetPriorityClipboardFormat :: Addr -> Int -> IO Int
 %fail {res1==-1}{ErrorWin("GetPriorityClipboardFormat")}
 
 %fun IsClipboardFormatAvailable :: ClipboardFormat -> IO BOOL

System/Win32/DLL.gc

 %fun GetModuleHandle :: MbString -> IO HMODULE
 %fail {res1 == NULL} {ErrorWin("GetModuleHandle")}
 
-%fun GetProcAddress :: HMODULE -> String -> IO (Ptr ())
+%fun GetProcAddress :: HMODULE -> String -> IO Addr
 %fail {res1 == NULL} {ErrorWin("GetProcAddress")}
 
 %fun LoadLibrary :: String -> IO HINSTANCE

System/Win32/Dialogue.gc

   DialogControl x y cx cy (Left 0x0084) (Right lab)
   		(style) estyle id
 
-%fun getFinalDialog :: Ptr () -> IO DTemplateMem
+%fun getFinalDialog :: Addr -> IO DTemplateMem
 
-%fun mkDiaTemplate :: Int -> Int -> Int -> Int -> Int -> WindowStyle -> DWORD -> Ptr a -> Ptr b -> Ptr c -> Ptr d -> Int -> IO (Ptr ())
+%fun mkDiaTemplate :: Int -> Int -> Int -> Int -> Int -> WindowStyle -> DWORD -> Ptr a -> Ptr b -> Ptr c -> Ptr d -> Int -> IO Addr
 
-addControl :: Ptr () -> DialogControl -> IO ()
+addControl :: Addr -> DialogControl -> IO ()
 addControl dtemp (DialogControl x y cx cy mb_text mb_class
 				style exstyle
 				id) = do
   		 x y cx cy exstyle
    return ()
 
-%fun addDiaControl :: Ptr () -> Ptr a -> Int -> Ptr b -> DWORD -> Int -> Int -> Int -> Int -> DWORD -> IO (Ptr ())
+%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

System/Win32/File.gc

 --Sigh - I give up & prefix win32_ to the next two to avoid
 -- senseless Prelude name clashes. --sof.
 
-%fun win32_ReadFile :: HANDLE -> Ptr () -> DWORD -> MbLPOVERLAPPED -> IO DWORD
+%fun win32_ReadFile :: HANDLE -> Addr -> DWORD -> MbLPOVERLAPPED -> IO DWORD
 %code BOOL success = ReadFile(arg1,arg2,arg3,&res1,arg4);
 %fail { !success } { ErrorString("ReadFile") }
 

System/Win32/MM.gc

 %#include "win32debug.h"
 %#include "finalizers.h"
 
-%fun CopyMemory :: Ptr () -> Ptr () -> DWORD -> IO ()
+%fun CopyMemory :: Addr -> Addr -> DWORD -> IO ()
 
-%fun FillMemory :: Ptr () -> DWORD -> BYTE -> IO ()
+%fun FillMemory :: Addr -> DWORD -> BYTE -> IO ()
 
 %fun GetProcessHeap :: IO HANDLE
 
-%fun GetProcessHeaps :: DWORD -> Ptr () -> IO DWORD
+%fun GetProcessHeaps :: DWORD -> Addr -> IO DWORD
 
-type   HGLOBAL   = Ptr ()
+type   HGLOBAL   = Addr
 %dis   hGLOBAL x = ptr ({HGLOBAL} x)
 
 type GlobalAllocFlags = UINT
 %fun GlobalFree :: HGLOBAL -> IO HGLOBAL
 %fail {res1==NULL}{ErrorWin("GlobalFree")}
 
-%fun GlobalHandle :: Ptr () -> IO HGLOBAL
+%fun GlobalHandle :: Addr -> IO HGLOBAL
 %fail {res1==NULL}{ErrorWin("GlobalHandle")}
 
-%fun GlobalLock :: HGLOBAL -> IO (Ptr ())
+%fun GlobalLock :: HGLOBAL -> IO Addr
 %fail {res1==NULL}{ErrorWin("GlobalLock")}
 
 -- %fun GlobalMemoryStatus :: IO MEMORYSTATUS
 % , HEAP_ZERO_MEMORY
 % ]
 
-%fun HeapAlloc :: HANDLE -> HeapAllocFlags -> DWORD -> IO (Ptr ())
+%fun HeapAlloc :: HANDLE -> HeapAllocFlags -> DWORD -> IO Addr
 %fail {res1==NULL}{ErrorWin("HeapAlloc")}
 
 %fun HeapCompact :: HANDLE -> HeapAllocFlags -> IO UINT
 %code BOOL res1=HeapDestroy(arg1);
 %fail {res1==0}{ErrorWin("HeapDestroy")}
 
-%fun HeapFree :: HANDLE -> HeapAllocFlags -> Ptr () -> IO ()
+%fun HeapFree :: HANDLE -> HeapAllocFlags -> Addr -> IO ()
 %code BOOL res1=HeapFree(arg1,arg2,arg3);
 %fail {res1==0}{ErrorWin("HeapFree")}
 
 %code BOOL res1=HeapLock(arg1);
 %fail {res1==0}{ErrorWin("HeapLock")}
 
-%fun HeapReAlloc :: HANDLE -> HeapAllocFlags -> Ptr () -> DWORD -> IO (Ptr ())
+%fun HeapReAlloc :: HANDLE -> HeapAllocFlags -> Addr -> DWORD -> IO Addr
 %fail {res1==NULL}{ErrorWin("HeapReAlloc")}
 
-%fun HeapSize :: HANDLE -> HeapAllocFlags -> Ptr () -> IO DWORD
+%fun HeapSize :: HANDLE -> HeapAllocFlags -> Addr -> IO DWORD
 %fail {res1==NULL}{ErrorWin("HeapSize")}
 
 %fun HeapUnlock :: HANDLE -> IO ()
 %code BOOL res1=HeapUnlock(arg1);
 %fail {res1==0}{ErrorWin("HeapUnlock")}
 
-%fun HeapValidate :: HANDLE -> HeapAllocFlags -> Ptr () -> IO Bool
+%fun HeapValidate :: HANDLE -> HeapAllocFlags -> Addr -> IO Bool
 
-%fun MoveMemory :: Ptr () -> Ptr () -> DWORD -> IO ()
+%fun MoveMemory :: Addr -> Addr -> DWORD -> IO ()
 
 type VirtualAllocFlags = DWORD
 %dis virtualAllocFlags x = dWORD x
 %const FreeFlags
 % [ MEM_DECOMMIT, MEM_RELEASE ]
 
-%fun VirtualAlloc :: Ptr () -> DWORD -> VirtualAllocFlags -> ProtectFlags -> IO (Ptr ())
+%fun VirtualAlloc :: Addr -> DWORD -> VirtualAllocFlags -> ProtectFlags -> IO Addr
 %fail {res1==NULL}{ErrorWin("VirtualAlloc")}
 
 
--- %fun VirtualAllocEx :: HANDLE -> Ptr () -> DWORD -> VirtualAllocFlags -> ProtectFlags ->IO (Ptr ())
+-- %fun VirtualAllocEx :: HANDLE -> Addr -> DWORD -> VirtualAllocFlags -> ProtectFlags ->IO Addr
 -- %code extern LPVOID WINAPI VirtualAllocEx(HANDLE,LPVOID,DWORD,DWORD,DWORD);
 -- %     LPVOID res1=VirtualAllocEx(arg1,arg2,arg3,arg4,arg5);
 -- %fail {res1==NULL}{ErrorWin("VirtualAllocEx")}
 
-%fun VirtualFree :: Ptr () -> DWORD -> FreeFlags -> IO ()
+%fun VirtualFree :: Addr -> DWORD -> FreeFlags -> IO ()
 %code BOOL res1=VirtualFree(arg1,arg2,arg3);
 %fail {res1=0}{ErrorWin("VirtualFree")}
 
--- %fun VirtualFreeEx :: HANDLE -> Ptr () -> DWORD -> FreeFlags -> IO ()
+-- %fun VirtualFreeEx :: HANDLE -> Addr -> DWORD -> FreeFlags -> IO ()
 -- %code extern BOOL WINAPI VirtualFreeEx(HANDLE,LPVOID,DWORD,DWORD);
 -- %     BOOL res1=VirtualFreeEx(arg1,arg2,arg3,arg4);
 -- %fail {res1=0}{ErrorWin("VirtualFreeEx")}
 
-%fun VirtualLock :: Ptr () -> DWORD -> IO ()
+%fun VirtualLock :: Addr -> DWORD -> IO ()
 %code BOOL res1=VirtualLock(arg1,arg2);
 %fail {res1=0}{ErrorWin("VirtualLock")}
 
-%fun VirtualProtect :: Ptr () -> DWORD -> ProtectFlags -> IO ()
+%fun VirtualProtect :: Addr -> DWORD -> ProtectFlags -> IO ()
 %code BOOL res1=VirtualLock(arg1,arg2);
 %fail {res1=0}{ErrorWin("VirtualProtect")}
 
-%fun VirtualProtectEx :: HANDLE -> Ptr () -> DWORD -> ProtectFlags -> Ptr () -> IO ()
+%fun VirtualProtectEx :: HANDLE -> Addr -> DWORD -> ProtectFlags -> Addr -> IO ()
 %code BOOL res1=VirtualProtectEx(arg1,arg2,arg3,arg4,arg5);
 %fail {res1=0}{ErrorWin("VirtualProtectEx")}
 
 -- No VirtualQuery..()
 
-%fun VirtualUnlock :: Ptr () -> DWORD -> IO ()
+%fun VirtualUnlock :: Addr -> DWORD -> IO ()
 %code BOOL res1=VirtualUnlock(arg1,arg2);
 %fail {res1=0}{ErrorWin("VirtualUnlock")}
 
-%fun ZeroMemory :: Ptr () -> DWORD -> IO ()
+%fun ZeroMemory :: Addr -> DWORD -> IO ()
 

System/Win32/Menu.gc

 %dis menuItemInfo x = << marshall_menuItemInfo / unmarshall_menuItemInfo >> (ptr x)
 
 
-marshall_menuItemInfo :: MenuItemInfo -> IO (Ptr ())
+marshall_menuItemInfo :: MenuItemInfo -> IO Addr
 marshall_menuItemInfo (MenuItemInfo miType 
 				    miState
 				    miItemID
                      miChecked miUnchecked miData pstr (length miTypeData)
   return ptr
 
-unmarshall_menuItemInfo :: Ptr () -> IO MenuItemInfo
+unmarshall_menuItemInfo :: Addr -> IO MenuItemInfo
 unmarshall_menuItemInfo ptr = do
    mi <- unravelItemInfo ptr
    free ptr
    return mi
 
-%fun unravelItemInfo :: Ptr () -> IO MenuItemInfo
+%fun unravelItemInfo :: Addr -> IO MenuItemInfo
 %code MENUITEMINFO* res1=arg1;
 %result (MenuItemInfo (uINT {res1->fType}) (uINT {res1->fState}) (uINT {res1->wID}) (hMENU {res1->hSubMenu}) (hBITMAP {res1->hbmpChecked}) (hBITMAP {res1->hbmpUnchecked}) (dWORD {res1->dwItemData}) (stringLen {res1->dwTypeData} {res1->cch}))
 
-%fun mallocMenuItemInfo :: IO (Ptr ())
+%fun mallocMenuItemInfo :: IO Addr
 %code mp = (MENUITEMINFO*) malloc(sizeof(MENUITEMINFO));
 %     if (mp!=NULL) mp->cbSize = sizeof(MENUITEMINFO);
 %fail {mp==NULL} { MallocError("mallocMenuItemInfo") }
 %result (ptr ({MENUITEMINFO*} mp))
 
-%fun assignMenuItemInfo :: Ptr () -> UINT -> UINT -> UINT -> HMENU -> HBITMAP -> HBITMAP -> DWORD -> CString -> Int -> IO ()
-%call (ptr arg1) (uINT arg2) (uINT arg3) (uINT arg4) (hMENU arg5) (hBITMAP arg6) (hBITMAP arg7) (dWORD arg8) (cString arg9) (int arg10)
+%fun assignMenuItemInfo :: Addr -> UINT -> UINT -> UINT -> HMENU -> HBITMAP -> HBITMAP -> DWORD -> CString -> Int -> IO ()
+%call (addr arg1) (uINT arg2) (uINT arg3) (uINT arg4) (hMENU arg5) (hBITMAP arg6) (hBITMAP arg7) (dWORD arg8) (cString arg9) (int arg10)
 %code MENUITEMINFO* ptr;
 %     ptr=(MENUITEMINFO*)arg1;
 %     ptr->fType         = arg2;

System/Win32/Registry.gc

         , regDeleteKey       -- :: HKEY -> String -> IO ()
 	, regDeleteValue     -- :: HKEY -> String -> IO ()
 	, regEnumKeys	     -- :: HKEY -> IO [String]
-	, regEnumKey 	     -- :: HKEY -> DWORD -> Ptr () -> DWORD -> IO String
-	, regEnumKeyValue    -- :: HKEY -> DWORD -> Ptr () -> DWORD -> Ptr () -> DWORD -> IO String
+	, regEnumKey 	     -- :: HKEY -> DWORD -> Addr -> DWORD -> IO String
+	, regEnumKeyValue    -- :: HKEY -> DWORD -> Addr -> DWORD -> Addr -> DWORD -> IO String
 	, regFlushKey        -- :: HKEY -> IO ()
 	, regLoadKey         -- :: HKEY -> String -> String -> IO ()
 	, regNotifyChangeKeyValue -- :: HKEY -> Bool -> RegNotifyOptions 
 	, regQueryInfoKey    -- :: HKEY -> IO RegInfoKey
 	, regQueryValue      -- :: HKEY -> MbString -> IO String
 	, regQueryValueKey   -- :: HKEY -> MbString -> IO String
-	, regQueryValueEx    -- :: HKEY -> String -> Ptr () -> Int -> IO RegValueType
+	, regQueryValueEx    -- :: HKEY -> String -> Addr -> Int -> IO RegValueType
 	, regReplaceKey      -- :: HKEY -> String -> String -> String -> IO ()
 	, regRestoreKey      -- :: HKEY -> String -> RegRestoreFlags -> IO ()
 	, regSaveKey         -- :: HKEY -> String -> MbLPSECURITY_ATTRIBUTES -> IO ()
 	, regSetValue        -- :: HKEY -> String -> String -> IO ()
-	, regSetValueEx      -- :: HKEY -> String -> RegValueType -> Ptr () -> Int -> IO ()
+	, regSetValueEx      -- :: HKEY -> String -> RegValueType -> Addr -> Int -> IO ()
 	, regSetStringValue  -- :: HKEY -> String -> String -> IO ()
 	, regUnloadKey       -- :: HKEY -> String -> IO ()
 	) where

System/Win32/Resource.gc

 %fun LoadResource :: HMODULE -> HRSRC -> IO HGLOBAL
 %fail {res1 == NULL} {ErrorWin("LoadResource")}
 
-%fun LockResource :: HGLOBAL -> IO (Ptr ())
+%fun LockResource :: HGLOBAL -> IO Addr
 %fail {res1 == NULL} {ErrorWin("LockResource")}
 
 %fun SizeofResource :: HMODULE -> HRSRC -> IO DWORD
 %fail {res1 == 0} {ErrorWin("SizeofResource")}
 
-%fun UpdateResource :: HANDLE -> LPCTSTR_ -> ResourceType -> WORD -> Ptr () -> DWORD -> IO ()
+%fun UpdateResource :: HANDLE -> LPCTSTR_ -> ResourceType -> WORD -> Addr -> DWORD -> IO ()
 %code BOOL res1 = UpdateResource(arg1,arg2,arg3,arg4,arg5,arg6);
 %fail { res1 == FALSE } {ErrorWin("UpdateResource")}
 

System/Win32/Types.gc

------------------------------------------------------------------------------
--- |
--- Module      :  System.Win32.Types
--- 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.Types
-	( module System.Win32.Types
-	, nullPtr
-	) where
-
-import Foreign.GreenCard
-
-%#include <stdlib.h>
-%#include <windows.h>
-%#include "errors.h"
-%#include "win32debug.h"
-%#include "finalizers.h"
-
-----------------------------------------------------------------
--- Platform specific definitions
---
--- Most typedefs and prototypes in Win32 are expressed in terms
--- of these types.  Try to follow suit - it'll make it easier to
--- get things working on Win64 (or whatever they call it on Alphas).
-----------------------------------------------------------------
-
-%dis bOOL x        = bool   ({BOOL}   x)
-%dis bYTE x        = word8  ({BYTE}   x)
-%dis uSHORT x      = word16 ({USHORT} x)
-%dis uINT x        = word32 ({UINT}   x)
-%dis iNT  x        = int32  ({INT}    x)
-%dis lONG x        = int32  ({LONG}   x)
-%dis wORD x        = word16 ({WORD}   x)
-%dis dWORD x       = word32 ({DWORD}  x)
-	           
-type BOOL          = Bool
-type BYTE          = Word8
-type USHORT        = Word16
-type UINT          = Word32
-type INT           = Int32
-type WORD          = Word16
-type DWORD         = Word32
-type LONG          = Int32
-type FLOAT         = Float
-	           
-type MbINT         = Maybe INT
-%dis mbINT x       = maybeT {0} (iNT x)
-
-----------------------------------------------------------------
-
-%dis aTOM x        = uINT ({ATOM}    x)
-%dis wPARAM x      = uINT ({WPARAM}  x)
-%dis lPARAM x      = lONG ({LPARAM}  x)
-%dis lRESULT x     = lONG ({LRESULT} x)
-	           
-type ATOM          = UINT
-type WPARAM        = UINT
-type LPARAM        = LONG
-type LRESULT       = LONG
-	           
-type MbATOM        = Maybe ATOM
-%dis mbATOM x      = maybeT {0} (aTOM x)
-
-----------------------------------------------------------------
--- Pointers
-----------------------------------------------------------------
-
-type LPVOID        = Ptr ()
-type LPCTSTR       = Ptr CChar
-type LPCTSTR_      = String
-type LPCSTR        = Ptr CChar
-type LPSTR         = Ptr CChar
-type LPTSTR        = Ptr CChar
-type LPBYTE        = Ptr BYTE
-
-%dis lPVOID x      = ptr ({LPVOID} x)
-%dis lPCSTR x      = ptr ({LPCSTR} x)
-%dis lPSTR  x      = ptr ({LPSTR} x)
-%dis lPCTSTR x     = ptr ({LPCTSTR} x)
-%dis lPTSTR x      = ptr ({LPTSTR} x)
-%dis lPBYTE x      = ptr ({LPBYTE} x)
-
-%dis lPCTSTR_ x    = lpctstr_ (ptr ({LPCTSTR} x))
-
--- Note: marshalling allocates mem, so the programmer
--- has to make sure to free this stuff up after any
--- uses of LPCTSTR. Automating this is tricky to do
--- (in all situations).
-
-%fun unmarshall_lpctstr_ :: Ptr CChar -> IO String
-%call (ptr arg1)
-%code char* res1;
-%     size_t l = wcstombs(NULL,arg1,-1);
-%     if ((res1=malloc(sizeof(char)*l)) == NULL ) {
-%        res1 = NULL;
-%     } else {
-%        wcstombs(res1,arg1,-1);
-%     }
-%fail { res1 == NULL } {ErrorWithCode("unmarshall_lpctstr_",0)}
-%result (string {res1})
-%end free(res1)
-
-%fun marshall_lpctstr_ :: String -> IO (Ptr CChar)
-%call (string arg1)
-%code wchar_t* res1;
-%     /* figure out how much to allocate */
-%     size_t l = mbstowcs(NULL,arg1,-1);
-%     if ((res1=malloc(sizeof(wchar_t)*l)) == NULL ) {
-%        res1 = NULL;
-%     } else {
-%        mbstowcs(res1,arg1,-1);
-%     }
-%fail { res1 == NULL } {ErrorWithCode("marshall_lpctstr_",0)}
-%result (ptr res1)
-
-type MbLPVOID      = Maybe LPVOID
-%dis mbLPVOID x    = maybeT {nullPtr} (lPVOID x)
-		   
-%dis mbLPCSTR x    = maybeT {nullPtr} (lPCSTR x)
-type MbLPCSTR      = Maybe LPCSTR
-%dis mbLPCTSTR x   = maybeT {nullPtr} (lPCTSTR x)
-type MbLPCTSTR     = Maybe LPCTSTR
-		   
-----------------------------------------------------------------
--- Handles
-----------------------------------------------------------------
-
-type   HANDLE      = Ptr ()
-%dis   hANDLE x    = ptr ({HANDLE} x)
-
-%fun handleToWord :: HANDLE -> UINT
-%code res1=(UINT)arg1
-		   
-type   HKEY      = ForeignPtr Stub_KEY
-data Stub_KEY
-%dis   hKEY x    = %ForeignPtr {HKEY} x {deleteObj}
-		   
-%const Ptr () [ nullHANDLE = {(HANDLE) NULL} ]
-
-type MbHANDLE      = Maybe HANDLE
-%dis mbHANDLE x    = maybeT {nullHANDLE} (hANDLE x)
-
-type   HINSTANCE   = Ptr ()
-%dis   hINSTANCE x = ptr ({HINSTANCE} x)
-type MbHINSTANCE   = Maybe HINSTANCE
-%dis mbHINSTANCE x = maybeT {nullHANDLE} (hINSTANCE x)
-
-type   HMODULE     = Ptr ()
-%dis   hMODULE x   = ptr ({HMODULE} x)
-type MbHMODULE     = Maybe HMODULE
-%dis mbHMODULE x   = maybeT {nullHANDLE} (hMODULE x)
-
-nullFinalHANDLE :: ForeignPtr a
-nullFinalHANDLE = unsafePerformIO (newForeignPtr nullPtr nullFunPtr)
-
-----------------------------------------------------------------
--- End
-----------------------------------------------------------------
-
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Types
+-- 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.Types
+	( module System.Win32.Types
+	, nullPtr
+	) where
+
+import Foreign.GreenCard
+
+%#include <stdlib.h>
+%#include <windows.h>
+%#include "errors.h"
+%#include "win32debug.h"
+%#include "finalizers.h"
+
+----------------------------------------------------------------
+-- Platform specific definitions
+--
+-- Most typedefs and prototypes in Win32 are expressed in terms
+-- of these types.  Try to follow suit - it'll make it easier to
+-- get things working on Win64 (or whatever they call it on Alphas).
+----------------------------------------------------------------
+
+%dis bOOL x        = bool   ({BOOL}   x)
+%dis bYTE x        = word8  ({BYTE}   x)
+%dis uSHORT x      = word16 ({USHORT} x)
+%dis uINT x        = word32 ({UINT}   x)
+%dis iNT  x        = int32  ({INT}    x)
+%dis lONG x        = int32  ({LONG}   x)
+%dis wORD x        = word16 ({WORD}   x)
+%dis dWORD x       = word32 ({DWORD}  x)
+
+type BOOL          = Bool
+type BYTE          = Word8
+type USHORT        = Word16
+type UINT          = Word32
+type INT           = Int32
+type WORD          = Word16
+type DWORD         = Word32
+type LONG          = Int32
+type FLOAT         = Float
+	           
+type MbINT         = Maybe INT
+%dis mbINT x       = maybeT {0} (iNT x)
+
+type Addr          = Ptr ()
+%dis addr x        = ptr ({HsPtr} x)
+
+----------------------------------------------------------------
+
+%dis aTOM x        = uINT ({ATOM}    x)
+%dis wPARAM x      = uINT ({WPARAM}  x)
+%dis lPARAM x      = lONG ({LPARAM}  x)
+%dis lRESULT x     = lONG ({LRESULT} x)
+	           
+type ATOM          = UINT
+type WPARAM        = UINT
+type LPARAM        = LONG
+type LRESULT       = LONG
+	           
+type MbATOM        = Maybe ATOM
+%dis mbATOM x      = maybeT {0} (aTOM x)
+
+----------------------------------------------------------------
+-- Pointers
+----------------------------------------------------------------
+
+type LPVOID        = Ptr ()
+type LPCTSTR       = Ptr CChar
+type LPCTSTR_      = String
+type LPCSTR        = Ptr CChar
+type LPSTR         = Ptr CChar
+type LPTSTR        = Ptr CChar
+type LPBYTE        = Ptr BYTE
+
+%dis lPVOID x      = ptr ({LPVOID} x)
+%dis lPCSTR x      = ptr ({LPCSTR} x)
+%dis lPSTR  x      = ptr ({LPSTR} x)
+%dis lPCTSTR x     = ptr ({LPCTSTR} x)
+%dis lPTSTR x      = ptr ({LPTSTR} x)
+%dis lPBYTE x      = ptr ({LPBYTE} x)
+
+%dis lPCTSTR_ x    = lpctstr_ (ptr ({LPCTSTR} x))
+
+-- Note: marshalling allocates mem, so the programmer
+-- has to make sure to free this stuff up after any
+-- uses of LPCTSTR. Automating this is tricky to do
+-- (in all situations).
+
+%fun unmarshall_lpctstr_ :: Ptr CChar -> IO String
+%call (ptr ({LPCTSTR} arg1))
+%code char* res1;
+%     size_t l = wcstombs(NULL,arg1,-1);
+%     if ((res1=malloc(sizeof(char)*l)) == NULL ) {
+%        res1 = NULL;
+%     } else {
+%        wcstombs(res1,arg1,-1);
+%     }
+%fail { res1 == NULL } {ErrorWithCode("unmarshall_lpctstr_",0)}
+%result (string {res1})
+%end free(res1)
+
+%fun marshall_lpctstr_ :: String -> IO (Ptr CChar)
+%call (string arg1)
+%code wchar_t* res1;
+%     /* figure out how much to allocate */
+%     size_t l = mbstowcs(NULL,arg1,-1);
+%     if ((res1=malloc(sizeof(wchar_t)*l)) == NULL ) {
+%        res1 = NULL;
+%     } else {
+%        mbstowcs(res1,arg1,-1);
+%     }
+%fail { res1 == NULL } {ErrorWithCode("marshall_lpctstr_",0)}
+%result (ptr ({LPCTSTR} res1))
+
+type MbLPVOID      = Maybe LPVOID
+%dis mbLPVOID x    = maybeT {nullPtr} (lPVOID x)
+		   
+%dis mbLPCSTR x    = maybeT {nullPtr} (lPCSTR x)
+type MbLPCSTR      = Maybe LPCSTR
+%dis mbLPCTSTR x   = maybeT {nullPtr} (lPCTSTR x)
+type MbLPCTSTR     = Maybe LPCTSTR
+		   
+----------------------------------------------------------------
+-- Handles
+----------------------------------------------------------------
+
+type   HANDLE      = Ptr ()
+%dis   hANDLE x    = ptr ({HANDLE} x)
+
+%fun handleToWord :: HANDLE -> UINT
+%code res1=(UINT)arg1
+		   
+type   HKEY      = ForeignPtr Stub_KEY
+data Stub_KEY
+%dis   hKEY x    = %ForeignPtr {HKEY} x {deleteObj}
+		   
+%const Addr [ nullHANDLE = {(HANDLE) NULL} ]
+
+type MbHANDLE      = Maybe HANDLE
+%dis mbHANDLE x    = maybeT {nullHANDLE} (hANDLE x)
+
+type   HINSTANCE   = Ptr ()
+%dis   hINSTANCE x = ptr ({HINSTANCE} x)
+type MbHINSTANCE   = Maybe HINSTANCE
+%dis mbHINSTANCE x = maybeT {nullHANDLE} (hINSTANCE x)
+
+type   HMODULE     = Ptr ()
+%dis   hMODULE x   = ptr ({HMODULE} x)
+type MbHMODULE     = Maybe HMODULE
+%dis mbHMODULE x   = maybeT {nullHANDLE} (hMODULE x)
+
+-- nullFinalHANDLE :: ForeignPtr a
+-- nullFinalHANDLE = unsafePerformIO (newForeignPtr nullPtr nullFunPtr)
+
+----------------------------------------------------------------
+-- End
+----------------------------------------------------------------

System/Win32/Window.gc

 % , CS_GLOBALCLASS
 % ]
 
-%dis wNDCLASS x = wndClass_ (ptr ({WNDCLASS *} x))
+%dis wNDCLASS x = wndClass_ (addr ({WNDCLASS *} x))
 
 type WNDCLASS =
  (ClassStyle,  -- style
 -- %code
 -- %result ((HBRUSH)($0+1));
 
-%fun marshall_wndClass_ :: WNDCLASS -> IO (Ptr ())
+%fun marshall_wndClass_ :: WNDCLASS -> IO (Addr)
 %call	( classStyle 	style
 %     	, hINSTANCE  	hInstance
 %     	, mbHICON    	hIcon
 %	  c->lpszClassName = lpszClassName;
 %     }
 %fail {c==0} { MallocError("marshall_WNDCLASS") }
-%result (ptr ({WNDCLASS*} c))
+%result (addr ({WNDCLASS*} c))
 
 %#include "WndProc.h"
 
 
 type WindowClosure = HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT
 
-%dis windowClosure x = windowClosure_ (ptr x)
+%dis windowClosure x = windowClosure_ (addr x)
  
-marshall_windowClosure_ :: WindowClosure -> IO (Ptr ())
+marshall_windowClosure_ :: WindowClosure -> IO (Addr)
 marshall_windowClosure_ cl = fmap funPtrToPtr (mkWindowClosure cl)
 
 foreign import ccall "wrapper" mkWindowClosure :: WindowClosure -> IO (FunPtr WindowClosure)
  , RECT  -- rcPaint
  )
 
-%dis lPPAINTSTRUCT x = ptr ({LPPAINTSTRUCT} x)
-type LPPAINTSTRUCT   = Ptr ()
+%dis lPPAINTSTRUCT x = addr ({LPPAINTSTRUCT} x)
+type LPPAINTSTRUCT   = Addr
 
 %fun sizeofPAINTSTRUCT :: DWORD
 %code
 --   , POINT  -- pt;
 --   )
 
-%dis lPMSG x = ptr ({MSG *} x)
-type LPMSG   = Ptr ()
+%dis lPMSG x = addr ({MSG *} x)
+type LPMSG   = Addr
 
 -- A NULL window requests messages for any window belonging to this thread.
 -- a "success" value of 0 indicates that WM_QUIT was received
 
 # -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.1 2003/04/05 18:00:32 reid Exp $
+# $Id: Makefile,v 1.2 2003/05/28 20:21:15 reid Exp $
 
-TOP = ../..
+TOP = ..
 include $(TOP)/mk/boilerplate.mk
 
 # -----------------------------------------------------------------------------
 
 SRC_CC_OPTS += -Wall -I../include
 
-LIBRARY = libHSX11_cbits.a
+LIBRARY = libHSWin32_cbits.a
 LIBOBJS = $(C_OBJS)
 
 # -----------------------------------------------------------------------------