[wxhaskell-from-cvs @ 2003-07-17 12:27:51 by dleijen]

Small makefile fixes for the Mac.
Better build project for windows MSC.
Initial support for client haskell data attached to objects.

darcs-hash:20030717122753-deb31-184f48ab5da1aed6dc9761134ce107942458c76d.gz

configure

@@ -8,7 +8,7 @@
 #  Copyright 2001, Daan Leijen.
 #------------------------------------------------------------------------
 
-# $Id: configure,v 1.2 2003/07/15 13:51:24 dleijen Exp $
+# $Id: configure,v 1.3 2003/07/17 12:27:51 dleijen Exp $
 
 #--------------------------------------------------------------------
 # Variables
@@ -558,6 +558,7 @@ USERNAME=$username
 # Standard programs
 INSTALL=$install
 INSTALLDIR=$installdir
+LD=ld
 AR=ar
 CP=cp -f
 MV=mv

makefile

@@ -2,7 +2,7 @@
 #  Copyright 2003, Daan Leijen.
 #-----------------------------------------------------------------------
 
-# $Id: makefile,v 1.9 2003/07/15 23:23:58 dleijen Exp $
+# $Id: makefile,v 1.10 2003/07/17 12:27:51 dleijen Exp $
 
 #--------------------------------------------------------------------------
 # make [all]	 - build the libraries (in "lib").
@@ -242,22 +242,39 @@ silent-move-stubs =$(call silent-move-file,$(basename $(2))_stub.h,$(dir $(1)));
 make-hs-obj     =$(call run-with-echo,$(HC) -c $(2) -o $(1) -ohi $(basename $(1)).hi -odir $(dir $(1)) $(3))
 
 # make-hs-deps(<output .o>,<input .hs>,<compile flags>)
-make-hs-deps	=$(HC) $(2) $(3) -M -optdep-f -optdep$(basename $(1)).d; \
-		 sed -i -e 's|$(basename $(2))|$(basename $(1))|' -e 's|\.hi|\.o|g' $(basename $(1)).d; \
-		 $(call silent-remove-file,$(basename $(1)).d.bak)
+make-hs-deps	=$(HC) $(2) $(3) -M -optdep-f -optdep$(basename $(1)).d.in && \
+		 sed -e 's|$(basename $(2))|$(basename $(1))|' -e 's|\.hi|\.o|g' $(basename $(1)).d.in > $(basename $(1)).d; \
+		 $(call silent-remove-file,$(basename $(1)).d.in)
 
 # compile-hs(<output .o>,<input .hs>,<compile flags>)
-compile-hs      =$(call make-hs-obj,$(1),$(2),$(3)); \
-		 $(call silent-move-stubs,$(1),$(2)); \
+compile-hs      =$(call make-hs-obj,$(1),$(2),$(3)) && \
+		 $(call silent-move-stubs,$(1),$(2)) && \
 		 $(call make-hs-deps,$(1),$(2),$(3))
 
 
+# make single-object file
+# combine-objs(<output .o>,<input .o files>)
+ifeq ($(TOOLKIT),mac)
+combine-objs	=$(LD) -x -r -o $(1) $(2)
+else
+combine-objs	=$(LD) -r -o $(1) $(2)
+endif
+
+# create an archive
+# make-archive(<archive>,<input .o files>)
+make-archive		=$(AR) -sr $(1) $(2)
+
+# update the archive symbol index
+# make-archive-index(<archive>)
+make-archive-index	=$(AR) -s $(1)
+
+
 # install files, keeping directory structure intact (that is why we use 'foreach').
 # we circumvent a 'ld' bug on the mac by also re-indexing archives on installation
 # usage: $(call install-files,<local dir>,<install dir>,<files>)
 # usage: $(call uninstall-files,<local dir>,<install dir>,<files>)
 install-file    =echo "install: $(2)"; $(INSTALL) $(1) $(dir $(2)); \
-	         $(foreach archive,$(filter %.a,$(2)),$(AR) -s $(archive);)
+	         $(foreach archive,$(filter %.a,$(2)),$(call make-archive-index,$(archive));)
 install-dir     =echo "install directory: $(1)"; $(INSTALLDIR) $(1);
 install-files   =$(foreach dir,$(call dirs-of-files,$(call relative-fromto,$(1),$(2),$(3))),$(call install-dir,$(dir))) \
 	         $(foreach file,$(3),$(call install-file,$(file),$(call relative-fromto,$(1),$(2),$(file))))
@@ -400,11 +417,11 @@ wx-uninstall:
 
 # build ghci object files
 $(WX-OBJ): $(WX-OBJS)
-	  $(LD) -r -o $@ $^
+	$(call combine-objs,$@,$^)
 
 # build a library
 $(WX-LIB): $(WX-OBJS)
-	  $(AR) -sr  $@ $^
+	$(call make-archive,$@,$^)
 
 # create an object file from source files.
 $(WX-OBJS): $(WX-IMPORTSDIR)/%.o: $(WX-SRCDIR)/%.hs
@@ -442,7 +459,7 @@ wxd-dist: $(WXD-HS)
 
 # build executable
 $(WXD-EXE): $(WXD-OBJS)
-	$(HC) $(HCFLAGS) -o $@ $(WXD-OBJS)
+	$(HC) $(HCFLAGS) -o $@ $^
 
 # create an object file from source files.
 $(WXD-OBJS): $(WXD-OUTDIR)/%.o: $(WXD-SRCDIR)/%.hs
@@ -522,17 +539,17 @@ $(WXH-SRCDIR)/$(WXH-HPATH)/WxcClassTypes.hs: $(WXD-EXE) $(WXC-SPECS-HEADER)
 
 # build ghci object files
 $(WXH-OBJ): $(WXH-OBJS)  $(WXH-STUB-OBJS)
-	  $(LD) -r -o $@ $^
+	  $(call combine-objs,$@,$^)
 
 $(WXH-CORE-OBJ): $(WXH-CORE-OBJS)
-	  $(LD) -r -o $@ $^
+	  $(call combine-objs,$@,$^)
 
 # build a library
 $(WXH-LIB): $(WXH-OBJS)  $(WXH-STUB-OBJS)
-	  $(AR) -sr  $@ $^
+	  $(call make-archive,$@,$^)
 
 $(WXH-CORE-LIB): $(WXH-CORE-OBJS)
-	  $(AR) -sr  $@ $^
+	  $(call make-archive,$@,$^)
 
 # create an object file from source files.
 $(WXH-CORE-OBJS) $(WXH-OBJS): $(WXH-IMPORTSDIR)/%.o: $(WXH-SRCDIR)/%.hs

wxc/include/wrapper.h

@@ -1,5 +1,8 @@
 #ifndef __WRAPPER_H
-#define __WRAPPER_H
+#define __WRAPPER_H
+
+/* MSC: disable warning about int-to-bool conversion (just affects performance) */
+#pragma warning(disable: 4800)
 
 #include "ewxw_def.h"
 #include "wx/wx.h"

wxh/src/Graphics/UI/WXH/Events.hs

@@ -123,19 +123,28 @@ module Graphics.UI.WXH.Events
         -- * Primitive
         , appOnInit
 
-        -- * Input sink
+        -- ** Client data
+        , objectWithClientData
+        , objectSetClientData
+
+        -- ** Input sink
         , inputSinkEventLastString
+
         -- ** Keys
         , KeyCode
         , modifiersToAccelFlags
         , keyCodeToKey, keyToKeyCode
+
         -- ** Events
         , windowOnEvent, windowOnEventEx
+
         -- ** Generic
         , OnEvent
         , evtHandlerOnEvent
         , evtHandlerOnEventConnect
+
         -- ** Unsafe
+        , unsafeObjectGetClientData
         , unsafeGetHandlerState
         , unsafeWindowGetHandlerState
         ) where
@@ -1444,6 +1453,8 @@ timerGetOnCommand timer
 -- Application startup
 ------------------------------------------------------------------------------------------
 -- | Installs an init handler and starts the event loop.
+-- Note: the closure is deleted when initialization is complete, and than the Haskell init function
+-- is started.
 appOnInit :: IO () -> IO ()
 appOnInit init
   = do closure  <- createClosure (return () :: IO ()) onDelete (\ev -> return ())   -- run init on destroy !
@@ -1457,6 +1468,38 @@ appOnInit init
     onDelete ownerDeleted
       = init
 
+
+------------------------------------------------------------------------------------------
+-- Attaching haskell data to arbitrary objects.
+------------------------------------------------------------------------------------------
+-- | Use attached haskell data locally. This makes it type-safe.
+objectWithClientData :: WxObject a -> b -> ((b -> IO ()) -> IO b -> IO c) -> IO c
+objectWithClientData object initx fun
+  = do let setter x = objectSetClientData object (return ()) x
+           getter   = do mb <- unsafeObjectGetClientData object
+                         case mb of
+                           Nothing -> return initx
+                           Just x  -> return x
+       setter initx
+       fun setter getter
+
+-- | Attach haskell value to an arbitrary object. The 'IO' action is executed
+-- when the object is deleted. Note: 'evtHandlerSetClientData' is preferred when possible.
+objectSetClientData :: WxObject a -> IO () -> b -> IO ()
+objectSetClientData object onDelete x
+  = do closure <- createClosure x (const onDelete) (const (return ()))
+       objectSetClientClosure object closure
+       return ()
+
+-- | Retrieve an attached haskell value.
+unsafeObjectGetClientData :: WxObject a -> IO (Maybe b)
+unsafeObjectGetClientData object
+  = do closure <- objectGetClientClosure object 
+       unsafeClosureGetData closure
+
+
+
+
 ------------------------------------------------------------------------------------------
 -- Generic window connection
 ------------------------------------------------------------------------------------------
@@ -1480,7 +1523,7 @@ unsafeWindowGetHandlerState window eventId def
        unsafeGetHandlerState window id eventId def
 
 ------------------------------------------------------------------------------------------
--- Generic event connection
+-- The current event
 ------------------------------------------------------------------------------------------
 {-# NOINLINE currentEvent #-}
 currentEvent :: MVar (Event ())
@@ -1506,6 +1549,9 @@ skipCurrentEvent :: IO ()
 skipCurrentEvent
   = withCurrentEvent (\event -> eventSkip event)
 
+------------------------------------------------------------------------------------------
+-- Generic event connection
+------------------------------------------------------------------------------------------
 -- | Retrievs the state associated with a certain event handler. If
 -- no event handler is defined for this kind of event or 'Id', the
 -- default value is returned.
@@ -1516,12 +1562,21 @@ unsafeGetHandlerState object id eventId def
 
 unsafeClosureGetState :: Closure () -> a -> IO a
 unsafeClosureGetState closure def
-  = if (closure==objectNull)
-     then return def
+  = do mb <- unsafeClosureGetData closure
+       case mb of
+         Nothing -> return def
+         Just x  -> return x
+
+unsafeClosureGetData :: Closure () -> IO (Maybe a)
+unsafeClosureGetData closure
+  = if (ptrIsNull closure)
+     then return Nothing
      else do ptr <- closureGetData closure
-             if (ptr==ptrNull)
-              then return def
-              else deRefStablePtr (castPtrToStablePtr ptr)
+             if (ptrIsNull ptr)
+              then return Nothing
+              else do x <- deRefStablePtr (castPtrToStablePtr ptr)
+                      return (Just x)
+
 
 -- | Type synonym to make the type signatures shorter for the documentation :-)
 type OnEvent = (Bool -> IO ()) -> (Event () -> IO ()) -> IO ()
@@ -1572,6 +1627,11 @@ evtHandlerOnEventConnect object firstId lastId eventIds state destroy eventHandl
       = evtHandlerConnect object firstId lastId eventId closure
 
 
+-- | Create a closure with a certain haskell state, a function that is called
+-- when the closure is destroyed, and a function that is called when an event
+-- happens. The destroy function takes a boolean that is 'True' when the parent
+-- is deleted (and 'False' when the closure is just disconnected). The event
+-- handlers gets the 'Event' as its argument.
 createClosure :: state -> (Bool -> IO ()) -> (Event () -> IO ()) -> IO (Closure ())
 createClosure st destroy handler
   = do funptr  <- wrapEventHandler eventHandlerWrapper