reactivity 0.2.3.0 → 0.3.0.0

raw patch · 10 files changed

+1023/−92 lines, 10 filesdep −Displayable

Dependencies removed: Displayable

Files

• reactivity.cabal +20/−8
• src/FRP/Reactivity.hs +33/−6
• src/FRP/Reactivity/Basic.hs +35/−25
• src/FRP/Reactivity/Combinators.hs +1/−1
• src/FRP/Reactivity/Draw.hs +3/−3
• src/FRP/Reactivity/Examples.hs +6/−1
• src/FRP/Reactivity/Extras.hs +33/−23
• src/FRP/Reactivity/UI.hs +49/−25
• src/Graphics/Subclass.hs +28/−0
• src/Graphics/Win32Extras.hs +815/−0

@@ -1,24 +1,31 @@ Name:                reactivity-Version:             0.2.3.0-Synopsis:            (Yet another) alternate implementation of push-pull FRP. This is based on the Reactive package (http://haskell.org/haskellwiki/reactive).+Version:             0.3.0.0+Synopsis:            An alternate implementation of push-pull FRP. Category:            reactivity, FRP-Description:+Description:         An alternate implementation of push-pull FRP. This is based on the Reactive package (http://haskell.org/haskellwiki/reactive) (and the sources have been made available in accordance with the GPL [license] of that package).+   .+   Known problems with this version:+   .+   * The UI library tends to freeze after a few seconds of use. Don't know whether the problem is semantical or a deadlock. The core library works correctly though.+   .+   * There seems to be a speed problem that I can't identify, but it doesn't appear to be fundamental.+   .+   * UI library is currently on Windows only, but there are plans.... Author:              James Candy Maintainer:          info@alkalisoftware.net-Homepage:            http://haskell.org/haskellwiki/reactive+Homepage:            http://www.alkalisoftware.net/Reactivity.html Package-Url:         http://code.haskell.org/reactivity Bug-Reports:         http://trac.haskell.org/reactivity -Copyright:           (c) 2015 by James Candy+Copyright:           (c) 2016 by James Candy Cabal-Version:       >= 1.2-License:             OtherLicense+License:             GPL License-File:        COPYING Stability:           provisional Build-Type:          Simple Extra-Source-Files: Library-    Build-Depends:       base >=4 && <5, time >= 1.5.0.1, random,-                         Win32, Displayable >= 0.2.0.0, bmp >= 1.2.5.2,+    Build-Depends:       base >=4 && <5, time >= 1.5.0.1, random, Win32, bmp >= 1.2.5.2,                          monad-loops >= 0.4.2.1, monads-tf >= 0.1.0.2, transformers >= 0.3.0.0, comonad,                          bytestring >= 0.10.0.2, array >= 0.4.0.1, ghc-prim, containers >=0.5.3.1, ConcurrentUtils >=0.4.0.0, parallel, list-extras     if impl(ghc < 6.9) {@@ -37,3 +44,8 @@         FRP.Reactivity.Examples         Data.XSizeable         Data.WeakDict++        Graphics.Subclass+    Other-Modules:+        Graphics.Win32Extras+    extra-libraries: gdi32, comdlg32, winspool, comctl32

@@ -4,9 +4,10 @@ -- library on Hackage. The functionals in Combinators are based on those from Reactive.
 module FRP.Reactivity (module Data.Time.Clock.POSIX, Time, Event, firstRestE,
 -- * Primitive event combinators (see also Monad and MonadPlus instances)
-cons, corec, withTime, withRest, once, over, displace, list, Stream(Stream), addToEvent, getEvent, chanSource,
+cons, corec, withTime, withRest, once, over, displace, list, firstE, Stream(Stream), addToEvent, getEvent, chanSource,
 -- * Executing events
-FrameOfReference, startT, setupFrame, makeFrame, runFrame, diagnostic) where
+FrameOfReference, startT, setupFrame, makeFrame, runFrame, diagnostic,
+Channel(Channel), chanWrite) where
 
 import GHC.Prim (Any)
 import Control.Concurrent
@@ -54,7 +55,7 @@ 	(Maybe t, Time, Event t)
 	-- Wait for the first external event in the dictionary. The Time parameter provides a time
 	-- limit, after which we will continue with the event parameter.
-	!(M.Map Integer (Handler Any t)) deriving (Typeable, Functor)
+	(M.Map Integer (Handler Any t)) deriving (Typeable, Functor)
 
 pureOccurrences (Event (_, t, _) _) | t == 1/0 = []
 pureOccurrences (Event (Nothing, _, e) _) = pureOccurrences e
@@ -89,6 +90,7 @@ 
 -- | Carry some kind of value which gets updated from occurrence to occurrence, and collect
 --   the results in an event.
+{-# INLINE[0] corec #-}
 corec :: (t -> u -> Time -> (t, v, Time)) -> t -> Event u -> Event v
 corec f x e = over e (\y t rest -> case f x y t of
 	(y, z, t2) -> cons z t2 (corec f y rest))
@@ -122,6 +124,7 @@ once e = over e (\x t _ -> cons x t mzero)
 
 -- | A case analysis on events.
+{-# INLINE over #-}
 over :: Event t -> (t -> Time -> Event t -> Event u) -> Event u
 over (Event (x, t, rest) mp) f = if isNothing x then
 		Event (Nothing, t, over rest f) mappedMp
@@ -148,6 +151,7 @@ 		displace' t (f x t2))) mp)
 
 -- | Displace occurrences to at least 't'.
+{-# INLINE displace #-}
 displace t e = Event (Nothing, t, displace' t e) M.empty
 -- Starting with a lower bound at 't' helps recursion be productive.
 
@@ -155,6 +159,22 @@ list ((x, t):xs) = cons x t (list xs)
 list [] = mzero
 
+firstE e e2 = join $ once $ duplicate e <> duplicate e2
+
+merge (Channel ref) (Channel ref2) f g =
+	if ref == ref2 then
+		return (Handler (Channel ref) (\x t -> f x t `mplus` g x t))
+		else do
+		my <- readIORef ref
+		my2 <- readIORef ref2
+		case (my, my2) of
+			(Just ((x, t), _), Nothing) -> return
+				(Handler (Channel ref2) (\x' t' -> f x t `mplus` g x' t'))
+			(Nothing, Just ((x, t), _)) -> return
+				(Handler (Channel ref) (\x' t' -> f x' t' `mplus` g x t))
+			_ -> -- This case should rarely happen; just try again
+				yield >> merge (Channel ref) (Channel ref2) f g
+
 instance MonadPlus Event where
 	mzero = Event (Nothing, 1/0, mzero) M.empty
 	mplus (Event (_, t, _) mp) e2 | t == 1/0 && M.null mp = e2
@@ -166,11 +186,11 @@ 			(x2, t2, mplus e rest2))
 		(fmap (\ei -> case ei of
 			Left ei2 -> case ei2 of
-				Left (Handler ref f) -> Handler ref (\x t -> mplus (f x t) e2)
-				Right (Handler ref f) -> Handler ref (\x t -> mplus e (f x t))
+				Left (Handler ref f) -> Handler ref (\x t -> f x t `mplus` e2)
+				Right (Handler ref f) -> Handler ref (\x t -> e `mplus` f x t)
 			Right h -> h)
 		$ M.unionWith
-			(\(Left (Left (Handler ref f))) (Left (Right (Handler _ g))) -> Right (Handler ref (\x t -> f x t `mplus` g x t)))
+			(\(Left (Left (Handler ref f))) (Left (Right (Handler ref2 g))) -> Right (unsafePerformIO $ merge ref ref2 f g))
 			(fmap (Left . Left) mp)
 			(fmap (Left . Right) mp2))
 
@@ -327,3 +347,10 @@ 	putStr (" at " ++ show t ++ ", map:")
 	ls <- mapM (\(n, Handler (Channel ref) _) -> liftM ((,) n . isJust) (readIORef ref)) (M.assocs mp)
 	print ls
+
+{-# RULES
+"corec/corec" forall f x g y e. corec f x (corec g y e) = corec
+	(\(x, y) z t -> case g y z t of (y', a, t') -> case f x a t' of (x', b, t'') -> ((x', y'), b, t''))
+	(x, y)
+	e
+  #-}

@@ -8,7 +8,6 @@ import Control.Monad.Reader
 import Control.Monad
 import Control.Applicative
-import Control.CUtils.FChan
 import Control.Concurrent hiding (newChan)
 import Control.Exception
 import Control.Comonad
@@ -17,19 +16,21 @@ import Data.Typeable (Typeable)
 import Data.Bits
 import Data.Time.Clock.POSIX
+import Data.Maybe
 import System.IO.Unsafe
 import System.Mem
 import FRP.Reactivity.Combinators
 import System.Win32
 import Graphics.Win32
 import Graphics.Win32Extras
+import System.IO
 
 start :: POSIXTime
 start = startT defaultFrame
 
 {-# NOINLINE ticks #-}
-ticks :: Stream ()
-ticks = unsafePerformIO (chanSource defaultFrame)
+ticks :: Stream Time
+ticks = Stream (const (return ())) (tick 0.1)
 
 nil = Stream (const (return ())) mzero
 
@@ -45,12 +46,16 @@ 
 -- The monad for Act continues with the actions expressed in 'f', for every tick in 'm'.
 instance Monad Act where
+	{-# INLINE return #-}
 	return = liftIO . return
+	{-# INLINE (>>=) #-}
 	Action m >>= f = Action $ do
 		ev <- m
 		stream <- chanSource defaultFrame
 		return $ fmap (\m -> m >>= maybe (return ()) ((>>= addToEvent stream) . unAction . f) >> return Nothing) ev
 			<> join (getEvent stream)
+	{-# INLINE[0] (>>) #-}
+	m >> m2 = m >>= const m2
 	fail _ = Action $ return mempty
 
 -- The Act monad has fixpoints.
@@ -105,7 +110,12 @@ -- | An I/O version of 'corec'
 corecA f x = corecA' f x . withTime
 
-run :: Act a -> IO ()
+{-# RULES
+"liftIO/liftIO" forall m m2. liftIO m >> liftIO m2 = liftIO (m >> m2)
+"liftE/liftIO" forall e m. liftE e >> liftIO m = liftE (fmap (>> m) e)
+  #-}
+
+run :: Act a -> IO b
 run action = do
 	-- Register window class
 	hdl <- getModuleHandle Nothing
@@ -116,32 +126,32 @@ 
 	-- Build and run the event stream
 	ev <- unAction action
-	(f, chn) <- newChan
-	setupFrame defaultFrame (fmap f (withTime ev))
-	forkIO (runFrame defaultFrame)
+	chn <- liftM Channel $ newIORef Nothing
+	end <- newIORef chn
+	ref <- newIORef chn
+	setupFrame defaultFrame (fmap (chanWrite end) ev)
+	thd <- forkIO (catch (runFrame defaultFrame) (\(ex :: SomeException) -> hPutStrLn stderr "Reactivity.Basic.run: Thread killed"))
 
 	-- Pump messages
 	allocaMessage $ \msg -> do
-	let m = do
-		-- Process all messages in the queue.
 		whileM_
-			(liftM (/=0) $ c_PeekMessage msg nullPtr 0 0 pM_REMOVE)
-			$ do
-			translateMessage msg
-			dispatchMessage msg
+			(return True)
+			(-- Dispatch an action
+			do
+			Channel ref' <- readIORef ref
+			my <- readIORef ref'
+			maybe (return ()) (\(m, chn') -> m >> writeIORef ref chn') my
 
-		-- Wait until either a message is received or the timeout elapses.
-		res <- msgWaitForMultipleObjects [] True 200 qS_ALLEVENTS
+			-- Process all messages in the queue.
+			whileM_
+				(liftM (/=0) $ c_PeekMessage msg nullPtr 0 0 pM_REMOVE)
+				$ do
+				translateMessage msg
+				dispatchMessage msg
 
-		when (res == wAIT_TIMEOUT) $ addToEvent ticks ()
+			when (isNothing my) yield
+			-- and repeat.
+			)
 
-	foldM_ (\chn _ ->
-		-- Process all available messages
-		tryTakeChan chn >>= maybe
-			(m >> return chn)
-			(\((m, _), rest) -> m >> return rest)
-		-- and repeat.
-		)
-		chn
-		(repeat ())
+	return undefined
 

@@ -234,7 +234,7 @@ scan :: Behavior (t -> Event t) -> t -> Event t
 scan b x = return x <> (snapshot (extract b x) (duplicate b) >>= uncurry (flip scan))
 
-_monoid e b = return b <> (snapshot (once (withRest e)) (duplicate b) >>= \((x, e), b2) -> _monoid e (b <> b2))
+_monoid e b = return b <> (snapshot (once (withRest e)) (duplicate b) >>= \((x, e), b2) -> _monoid e (x <> b2))
 
 -- | Collect the event occurrences and add them together into a single behavior, using a monoid.
 {-# INLINE monoid #-}

@@ -104,7 +104,7 @@ newBitmap dim = fst $ onNewBitmap dim (return ())
 
 -- | Make a copy of a bitmap and draw on it. This only works with 24-bit bitmaps
---   (but the Codec.BMP library provides conversion functions)
+--   (but the Codec.BMP library provides conversion functions).
 {-# NOINLINE onBitmap #-}
 onBitmap bmp draw = unsafeOnBitmap (bmp { bmpRawImageData = copy $ bmpRawImageData bmp }) draw
 
@@ -530,12 +530,12 @@ ----------------------------------------
 -- Drawing in a device context.
 
-drawBitmap wnd hdc wd ht p = do
+drawBitmap wnd hdc wd ht x y p = do
 	let wd32 = fromIntegral wd
 	let ht32 = fromIntegral ht
 	-- Draw the bitmap
 	withBITMAP (InfoV3 (BitmapInfoV3 40 wd ht False 1 24 CompressionRGB (4 * wd32 * ht32) 0 0 0 0)) $ \pBmp ->
-		c_SetDIBitsToDevice hdc 0 0 wd32 ht32 0 0 0 ht32 p pBmp dIB_RGB_COLORS
+		c_SetDIBitsToDevice hdc x y wd32 ht32 0 0 0 ht32 p pBmp dIB_RGB_COLORS
 
 -- | Put up a quick window to visualize the drawing as it's being drawn.
 graffito (x1, y1, x2, y2) d = do

@@ -26,7 +26,7 @@ 	wnd <- create desktop "Frame" (pure (Appearance mempty "Counter" (0, 0, 400, 300)))  	-- and a button...-	w <- create wnd "BUTTON" (pure (mempty { rect = (0, 0, 200, 20), text = "Count" }))+	w <- create wnd "BUTTON" (pure $ Appearance (D.fillRect (rgb 255 0 0) (0, 0, 200, 20)) "Count" (0, 0, 200, 20))  	-- Make a label with a behavior that shows the count... 	let beh = stepper mempty $ corec (\pr@(_, n) msg t -> case msg of@@ -51,6 +51,11 @@ mouseTracker = run $ do 	ev <- liftIO (chanSource defaultFrame) 	runHook (hCreate "Frame" (trackingBox (getEvent ev)) (autoclose >> window >>= \w -> lift (liftE (fmap return (event w))) >>= liftIO . addToEvent ev))++blinky = run $ runHook $ ty $ hCreate "Frame" (fmap (\n -> Appearance (D.function (0, 0, 32767, 32767) (\_ x y -> rgb+	0+	(fromIntegral $ (x ^ 2 + y ^ 2) * round (n * 16))+	(fromIntegral $ (x ^ 2 - y ^ 2) * round (n * 16)))) "" (0, 0, 400, 300)) time) autoclose  -- Scrollbars scrollbars = run $ runHook $

@@ -244,8 +244,8 @@ convert reac ev = (mempty { text = "0,0,0" },
 	(\(pos, (rt, mx)) _ -> let (wid, ht) = dim rt in
 	Appearance (return ()) (show mx
-		++ ',' : show (max wid ht)
-		++ ',' : show pos) rt)
+		++ ',' : show pos
+		++ ",0") rt)
 	<$>
 	snapshot ev reac)
 
@@ -255,44 +255,54 @@ 	Close -> Just (Pair 0 0)
 	_ -> Nothing))
 
+shiftControls :: Event (Int32, Int32)
+	-> Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act t
+	-> Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act (t, Event Window)
+shiftControls displacement h = do
+	-- Add a hook to move controls around
+	-- and a hook to make this invisible to other components
+ 	let adjust = (\((x, y), (x2, y2)) appr ->
+		appr { rect = shift (x2 - x, y2 - y) (rect appr) })
+		<$>
+		withPrev (cons (0, 0) 0 displacement)
+	getReturns (mempty, adjust) id h
+
+	{-let adjust2 ev = (\(msg, (xPos, yPos)) -> case msg of
+		Move rt -> Move $ shift (xPos, yPos) rt
+		_ -> msg)
+		<$>
+		holdE
+			ev
+			(zipE (getChanges (event hw)) 0 (getChanges (event vw)) 0)
+			(0, 0)-}
+
 -- | If some child controls are out of view,
 -- adds scroll bars that allow the user to access them.
 scroll :: Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act t -> Hook (Appearance, Event (Appearance -> Appearance)) (Event Message) Act t
-scroll h = liftM fst $ mfix $ \ ~(_, functional) -> do
+scroll h = do
 	wnd <- window
 	adjustStream <- liftIO $ chanSource defaultFrame
-	~(x, children) <- getReturns (mempty, getEvent adjustStream) id h
+	~(x, children) <- shiftControls (getEvent adjustStream) h
 	let changes = justE $ fmap (\msg -> case msg of Move rt -> Just (dim rt); _ -> Nothing) (event wnd)
 	let hDim = fmap (\(wid, ht) -> (0, ht - barSize, wid - barSize, ht)) changes
 	let vDim = fmap (\(wid, ht) -> (wid - barSize, 0, wid, ht - barSize)) changes
 	let ext = extent (fmap event children)
-	hw <- hCreate' "SCROLLBAR" $ convert ((,)
+	hw <- hCreate' "HSCROLLBAR" $ convert ((,)
 		<$> stepper empt hDim
 		<*> fmap (\(Pair x _) -> x) ext)
-		(position (event wnd))
+		(fmap (\(_, _, x, _) -> x) $ position (event wnd))
 	vw <- hCreate' "SCROLLBAR" $ convert ((,)
 		<$> stepper empt vDim
 		<*> fmap (\(Pair _ x) -> x) ext)
-		(position (event wnd))
-	-- Add a hook to move controls around
-	-- and a hook to make this invisible to other components
- 	let adjust = (\(xPos, yPos) appr@(Appearance _ _ (x, y, _, _)) ->
-		appr { rect = shift (x - xPos, y - yPos) (rect appr) })
-		<$>
-		zipE (getChanges (event hw)) 0 (getChanges (event vw)) 0
-	let adjust2 ev = (\(msg, (xPos, yPos)) -> case msg of
-		Move rt -> Move $ shift (xPos, yPos) rt
-		_ -> msg)
-		<$>
-		holdE
-			ev
-			(zipE (getChanges (event hw)) 0 (getChanges (event vw)) 0)
-			(0, 0)
-	lift $ liftS adjustStream $ fmap return adjust
-	return (x, functional) where
+		(fmap (\(_, _, _, y) -> y) $ position (event wnd))
+	lift $ liftS adjustStream $ return <$> zipE (negate <$> getChanges (event hw)) 0 (negate <$> getChanges (event vw)) 0
+	return x where
 	empt = (0, 0, 0, 0)
 	getChanges = justE . fmap (\msg -> case msg of Change s -> Just (read s); _ -> Nothing)
 
 barSize :: LONG
 barSize = 18
 
+theStyle h = getReturns (fillRect 0xbebed4 (0, 0, 32767, 32767)
+	>> mapM_ (\y -> mapM_ (\x -> blend (fromIntegral y / 200) (x, y) 0x404092) [0..199]) [0..399])
+	h

@@ -26,7 +26,7 @@ import Control.Monad
 import Control.Monad.Loops
 import Control.Monad.Reader
-import Control.Exception
+import Control.Exception hiding (mask)
 import Codec.BMP
 import Prelude hiding (until)
 
@@ -94,10 +94,6 @@ toLPARAM :: Ptr a -> LPARAM
 toLPARAM = unsafeCoerce
 
-{-# NOINLINE ref #-}
-ref :: IORef Appearance
-ref = unsafePerformIO $ newIORef $ Appearance (return ()) "" (0, 0, 0, 0)
-
 data Window = Window { hwnd :: !HWND, event :: Event Message } -- The type of windows.
 
 -- | A window representing the desktop.
@@ -122,7 +118,7 @@ regulate :: Event t -> Act (Event t)
 regulate e = liftM justE $ allOccs (corecA (\t1 x t -> do
 	t1' <- getPOSIXTime
-	if t >= fromRational (toRational (t1 - start)) then
+	if t < fromRational (toRational (t1 - start)) then
 			return (t1', Just x, t)
 		else
 			return (t1, Nothing, t))
@@ -155,7 +151,8 @@ 
 create :: Window -> WndClass -> Behavior Appearance -> Act Window
 create (Window parent parentEv) cls beh = do
-	(wnd, ev) <- liftE $ return $ createWnd parent cls
+	ref <- liftIO $ newIORef $ Appearance (return ()) "" (0, 0, 0, 0)
+	(wnd, ev) <- liftIO $ createWnd parent cls ref
 	let ev' = return (Internal (Tick nullPtr)) <> if isFrame cls then
 			ev
 		else
@@ -177,6 +174,8 @@ 
 read' x = if all isDigit x then read x else unsafePerformIO (print x >> return 0)
 
+isScrollBar cls = map toUpper cls `elem` ["SCROLLBAR", "HSCROLLBAR"]
+
 update wnd cls ((msg, Appearance draw text (x, y, xx, yy)), suspend) = do
 	mp <- readIORef suspendedUpdateWindows
 	unless (M.member wnd mp) (catch (do
@@ -203,19 +202,16 @@ 					(fromIntegral ht)
 					sWP_NOZORDER
 
-		-- Set scrollbar direction
-		when (map toUpper cls == "SCROLLBAR") $ void $ setWindowLong wnd gWLP_STYLE $ fromIntegral $ wS_VISIBLE .|. wS_CHILDWINDOW .|. if wid > ht then sBS_HORZ else sBS_VERT
-
 		-- Set the text
-		case map toUpper cls of
-			"SCROLLBAR" -> do
+		if isScrollBar cls then
+			do
 				let (mx, _:rest) = break (==',') text
 				let (page, _:pos) = break (==',') rest
 				old <- getScrollInfo wnd (fromIntegral sB_CTL)
 				let mask = sIF_RANGE .|. sIF_POS .|. if suspend then 0 else sIF_POS
 				let new = SCROLLINFO mask 0 (read' mx) (read' page) (read' pos) 0
 				unless (old { fMask = mask } == new) $ void $ setScrollInfo wnd (fromIntegral sB_CTL) new
-			_ -> do
+			else do
 				prev <- getText wnd
 				when (isFrame cls || not suspend && prev /= text) $ setWindowText wnd text
 
@@ -267,7 +263,31 @@ 
 getText wnd = catch (getWindowText wnd) (\(_ :: IOError) -> return "")
 
-createWnd parent cls = do
+drawButton wnd hdc app wid ht p bkclr clr = do
+	hilite <- getSysColor cOLOR_BTNHIGHLIGHT
+	shadow <- getSysColor cOLOR_BTNSHADOW
+	grayed <- getSysColor cOLOR_GRAYTEXT
+	state <- peekByteOff p 16
+	let (upperLeft, lowerRight, pushDown) = if state .&. oDS_SELECTED /= 0 then (shadow, hilite, 2) else (hilite, shadow, 0)
+	-- let (txtX, txtY) = extent txt
+	-- let left = (wid - (drawX + 4 + txtX)) `div` 2 + pushDown
+	let margin = 10
+	runReaderT (unDraw (do
+		fillRect upperLeft (0, 0, wid, 1)
+		fillRect upperLeft (0, 0, 1, ht - 1)
+		fillRect lowerRight (0, ht - 1, wid, ht)
+		fillRect lowerRight (wid - 1, 1, wid, ht)
+		fillRect bkclr (1, 1, wid - 1, ht - 1)
+		FRP.Reactivity.Draw.textOut (text app) (margin + 32, margin) defFont
+		mask 1 (1, 1) (fst $ onNewBitmap (wid - 2, ht - 2) (draw app))))
+		((wid, ht), p, Nothing)
+	drawBitmap wnd hdc (fromIntegral wid) (fromIntegral ht) 0 0 p
+	-- let txt = Text (0, 0) (snd $ isEnabled $ text wnd) 12 "Tahoma" bkclr (if state .&. oDS_DISABLED /= 0 then grayed else clr)
+	{-when (state .&. oDS_FOCUS /= 0) $ do
+		drawFocusRect dc (2, 2, wid - 2, ht - 2)
+		return ()-}
+
+createWnd parent cls ref = do
 	-- Make event fed by the window
 	Stream sink ev <- chanSource defaultFrame
 	bmp :: SA Int32 CChar <- newArray_ (0, -1)
@@ -281,17 +301,20 @@ 			let sz = 4 * wid * ht
 			resize (0, sz - 1) bmp
 			(_, p) <- getPtr bmp
-			memset p 0 (fromIntegral sz)
 			runReaderT (unDraw (fillRect defBackground (0, 0, wid, ht) >> draw app)) ((wid, ht), p, Nothing)
 			if msg == wM_PAINT && isFrame cls then
 				allocaPAINTSTRUCT $ \ps -> do
 					hdc <- beginPaint wnd ps
-					drawBitmap wnd hdc (fromIntegral wid) (fromIntegral ht) p
+					drawBitmap wnd hdc (fromIntegral wid) (fromIntegral ht) 0 0 p
 					endPaint wnd ps
-				else if msg == wM_DRAWITEM then void $ do
-					(wnd, hdc) <- catch (liftM2 (,) (peekByteOff (unsafeCoerce lParam) 20) (peekByteOff (unsafeCoerce lParam) 24)) (\(_ :: IOException) -> return (nullPtr, nullPtr))
-					drawBitmap wnd hdc (fromIntegral wid) (fromIntegral ht) p
-					drawText hdc (text app) (0, 0, wid, ht) (dT_VCENTER .|. dT_SINGLELINE)
+				else if msg == wM_DRAWITEM then do
+					let drawStruct = unsafeCoerce lParam
+					(wnd, hdc) <- catch (liftM2 (,) (peekByteOff drawStruct 20) (peekByteOff drawStruct 24)) (\(_ :: IOException) -> return (nullPtr, nullPtr))
+					if map toUpper cls == "BUTTON" then do
+						void $ drawButton wnd hdc app wid ht p (rgb 255 255 255) 0
+						else void $ do
+						drawBitmap wnd hdc (fromIntegral wid) (fromIntegral ht) 0 0 p
+						drawText hdc (text app) (0, 0, wid, ht) (dT_VCENTER .|. dT_SINGLELINE)
 				else when (msg == wM_CTLCOLORSTATIC) $ void $ setBkMode (unsafeCoerce wParam) tRANSPARENT)
 			(\x -> do
 				print x
@@ -311,7 +334,6 @@ 		-- An application can't be expected to respond to WM_ENDSESSION immediately,
 		-- therefore it holes up in an event loop here, waiting for approval
 		-- from the app to close.
-		-- !!! Must do everything here that is done in event loop
 		when (msg == wM_ENDSESSION) $ allocaMessage $ \msg ->
 			untilM_
 				(return ())
@@ -330,12 +352,14 @@ 
 	-- Create the window
 	hdl <- getModuleHandle Nothing
-	let name = mkClassName cls
+	let name = mkClassName (if isScrollBar cls then "SCROLLBAR" else cls)
 	wnd <- createWindow name "" (wS_CLIPCHILDREN .|. wS_VISIBLE .|. case map toUpper cls of
 		"FRAME" -> wS_OVERLAPPEDWINDOW
 		"STATIC" -> wS_CHILDWINDOW .|. sS_OWNERDRAW
+		"BUTTON" -> wS_CHILDWINDOW .|. bS_OWNERDRAW
 		"EDIT" -> wS_CHILDWINDOW .|. eS_AUTOHSCROLL
-		"SCROLLBAR" -> wS_CHILDWINDOW .|. sBS_HORZ
+		"SCROLLBAR" -> wS_CHILDWINDOW .|. sBS_VERT
+		"HSCROLLBAR" -> wS_CHILDWINDOW .|. sBS_HORZ
 		_ -> wS_CHILDWINDOW) (Just 0) (Just 0) (Just 0) (Just 0) (Just parent) Nothing hdl (handler (defWindowProc . Just))
 	updateWindow wnd
 
@@ -394,10 +418,10 @@ 				setScrollInfo (unsafeCoerce lParam) (fromIntegral sB_CTL) (si { nPos = newY })
 				return $ Just $ Internal $ IChange (show $ max 0 (min newY (nMax si - fromIntegral (nPage si)))) (unsafeCoerce lParam)
 	else if msg == wM_WINDOWPOSCHANGED then do
-		rt@(x1, y1, x2, y2) <- getWindowRect hwnd
 		liftM (Just . Move) $ if parent == nullPtr then
-				return rt
+				getClientRect hwnd
 			else do
+				rt <- getWindowRect hwnd
 				(cx, cy) <- clientToScreen parent (0, 0)
 				return (shift (-cx, -cy) rt)
 	else if msg == wM_ACTIVATE && wParam == 1 then

@@ -0,0 +1,28 @@+module Graphics.Subclass (subclassProc) where
+
+import Unsafe.Coerce
+import Data.IORef
+import Foreign.Ptr
+import Control.Monad
+import Graphics.Win32
+import Graphics.Win32Extras
+
+-- | This function subclasses a window and takes care of freeing
+-- the function pointer when the window closes. The parameter function
+-- is passed a function that invokes the default behaviour of the
+-- window.
+subclassProc :: HWND -> (WindowClosure -> WindowClosure) -> IO ()
+subclassProc wnd proc = do
+	procVar <- newIORef Nothing
+	let closure wnd msg wParam lParam = do
+		may <- readIORef procVar
+		case may of
+			Just (funPtr, oldProc) -> do
+				when (msg == wM_NCDESTROY) $ do
+					c_SetWindowLongPtr wnd gWLP_WNDPROC oldProc
+					freeHaskellFunPtr funPtr
+				proc (callWindowProc (unsafeCoerce oldProc)) wnd msg wParam lParam
+			Nothing -> proc (\_ _ _ _ -> return 0) wnd msg wParam lParam
+	funPtr <- mkWindowClosure closure
+	oldProc <- c_SetWindowLongPtr wnd gWLP_WNDPROC (unsafeCoerce funPtr)
+	writeIORef procVar (Just (funPtr, oldProc))

@@ -0,0 +1,815 @@+{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}
+module Graphics.Win32Extras where
+
+import Graphics.Win32
+import System.Win32.DLL
+import Data.Int
+import Data.Word
+import Data.Bits
+import Foreign.ForeignPtr
+import Foreign.Ptr
+import Foreign.Storable
+import Foreign.Marshal.Alloc
+import Foreign.C.Types
+import Data.IORef
+import System.IO.Unsafe
+import Control.Monad
+import Control.Monad.Loops
+import Codec.BMP
+
+foreign import stdcall "windows.h GetWindowTextW" c_GetWindowText :: HWND -> LPTSTR -> Int32 -> IO LRESULT
+
+-- | A wrapper for 'c_GetWindowText' which fails if the string is too long.
+getWindowText wnd = do
+	fp <- mallocForeignPtrBytes 1024
+	withForeignPtr fp $ \p -> do
+		pokeByteOff p 1021 '\0'
+		failIfZero "GetWindowText" $ c_GetWindowText wnd p 1024
+		ch :: Word8 <- peekByteOff p 1021
+		failIf_ id "GetWindowText" $ return $ ch /= 0 -- Test if string was truncated
+		peekTString p
+
+foreign import stdcall "windows.h GetClassNameW" c_GetClassName :: HWND -> LPTSTR -> Int32 -> IO LRESULT
+
+getClassName wnd = do
+	fp <- mallocForeignPtrBytes 1024
+	withForeignPtr fp $ \p -> do
+		pokeByteOff p 1021 '\0'
+		failIfZero "GetClassName" $ c_GetClassName wnd p 1024
+		ch :: Word8 <- peekByteOff p 1021
+		failIf_ id "GetClassName" $ return $ ch /= 0 -- Test if string was truncated
+		peekTString p
+
+foreign import stdcall "windows.h SetFocus" setFocus :: HWND -> IO HWND
+
+------------------------------
+-- Drawing
+
+foreign import stdcall unsafe "windows.h SetPixel" set :: HDC -> Int32 -> Int32 -> COLORREF -> IO COLORREF
+
+dT_TOP :: Word32
+dT_TOP = 0
+
+dT_LEFT :: Word32
+dT_LEFT = 0
+
+dT_CENTER :: Word32
+dT_CENTER = 1
+
+dT_RIGHT :: Word32
+dT_RIGHT = 2
+
+dT_VCENTER :: Word32
+dT_VCENTER = 4
+
+dT_BOTTOM :: Word32
+dT_BOTTOM = 8
+
+dT_WORDBREAK :: Word32
+dT_WORDBREAK = 16
+
+dT_SINGLELINE :: Word32
+dT_SINGLELINE = 32
+
+dT_EXPANDTABS :: Word32
+dT_EXPANDTABS = 64
+
+dT_TABSTOP :: Word32
+dT_TABSTOP = 128
+
+dT_NOCLIP :: Word32
+dT_NOCLIP = 256
+
+dT_EXTERNALLEADING :: Word32
+dT_EXTERNALLEADING = 512
+
+dT_CALCRECT :: Word32
+dT_CALCRECT = 1024
+
+dT_NOPREFIX :: Word32
+dT_NOPREFIX = 2048
+
+dT_INTERNAL :: Word32
+dT_INTERNAL = 4096
+
+dT_EDITCONTROL :: Word32
+dT_EDITCONTROL = 8192
+
+dT_PATH_ELLIPSIS :: Word32
+dT_PATH_ELLIPSIS = 16384
+
+dT_END_ELLIPSIS :: Word32
+dT_END_ELLIPSIS = 32768
+
+dT_MODIFYSTRING :: Word32
+dT_MODIFYSTRING = 65536
+
+dT_RTLREADING :: Word32
+dT_RTLREADING = 131072
+
+dT_WORD_ELLIPSIS :: Word32
+dT_WORD_ELLIPSIS = 262144
+
+dT_NOFULLWIDTHCHARBREAK :: Word32
+dT_NOFULLWIDTHCHARBREAK = 524288
+
+dT_HIDEPREFIX :: Word32
+dT_HIDEPREFIX = 1048576
+
+dT_PREFIXONLY :: Word32
+dT_PREFIXONLY = 2097152
+
+foreign import stdcall "windows.h DrawTextW" c_DrawText :: HDC -> LPTSTR -> Int32 -> LPRECT -> UINT -> IO Int32
+
+drawText dc s rt format = withTString s $ \ps ->
+	withRECT rt $ \pr ->
+	failIfZero "DrawText" $ c_DrawText dc ps (-1) pr format
+
+foreign import stdcall "windows.h SetDIBitsToDevice"
+	c_SetDIBitsToDevice :: HDC -> Int32 -> Int32 -> Word32 -> Word32 -> Int32 -> Int32 -> Word32 -> Word32 -> Ptr CChar -> LPBITMAPINFO -> Word32 -> IO Int32
+
+withBITMAP :: BitmapInfo -> (Ptr () -> IO a) -> IO a
+withBITMAP (InfoV3 bi) f = do
+	fp <- mallocForeignPtrBytes 40
+	withForeignPtr fp $ \p -> do
+		pokeByteOff p 0 (dib3Size bi)
+		pokeByteOff p 4 (dib3Width bi)
+		pokeByteOff p 8 (dib3Height bi)
+		pokeByteOff p 12 (dib3Planes bi)
+		pokeByteOff p 14 (dib3BitCount bi)
+		pokeByteOff p 16 bI_RGB
+		pokeByteOff p 20 (dib3ImageSize bi)
+		pokeByteOff p 24 (dib3PelsPerMeterX bi)
+		pokeByteOff p 28 (dib3PelsPerMeterY bi)
+		pokeByteOff p 32 (dib3ColorsUsed bi)
+		pokeByteOff p 36 (dib3ColorsImportant bi)
+		f p
+
+type XFORM = Ptr ()
+
+foreign import stdcall "windows.h SetWorldTransform" setWorldTransform :: HDC -> XFORM -> IO Bool
+
+withXFORM :: (Float, Float, Float, Float, Float, Float) -> (XFORM -> IO t) -> IO t
+withXFORM (eM11, eM12, eM21, eM22, eDx, eDy) f = do
+	fp <- mallocForeignPtrBytes 24
+	withForeignPtr fp $ \p -> do
+		pokeByteOff p 0 eM11
+		pokeByteOff p 4 eM12
+		pokeByteOff p 8 eM21
+		pokeByteOff p 12 eM22
+		pokeByteOff p 16 eDx
+		pokeByteOff p 20 eDy
+		f p
+
+oDT_BUTTON :: Word32
+oDT_BUTTON = 4
+
+oDA_DRAWENTIRE :: Word32
+oDA_DRAWENTIRE = 1
+
+oDA_SELECT :: Word32
+oDA_SELECT = 2
+
+oDA_FOCUS :: Word32
+oDA_FOCUS = 4
+
+oDS_SELECTED :: Word32
+oDS_SELECTED = 1
+
+oDS_DISABLED :: Word32
+oDS_DISABLED = 4
+
+oDS_FOCUS :: Word32
+oDS_FOCUS = 16
+
+foreign import stdcall "windows.h DrawFocusRect" c_DrawFocusRect :: HDC -> LPRECT -> IO Bool
+
+drawFocusRect dc rt = withRECT rt $ c_DrawFocusRect dc
+
+foreign import stdcall "windows.h SetWindowPos" c_SetWindowPos :: HWND -> HWND -> LONG -> LONG -> LONG -> LONG -> Word32 -> IO Bool
+
+setWindowPos hwnd hwndAfter x y wd ht flags = failIfFalse_ "SetWindowPos" $ c_SetWindowPos hwnd hwndAfter x y wd ht flags
+
+foreign import stdcall "windows.h SetWindowLongW" setWindowLong :: HWND -> LONG -> LONG -> IO LONG
+
+------------------------------
+-- Scroll bars
+
+foreign import stdcall "windows.h SetScrollInfo" c_SetScrollInfo :: HWND -> Int32 -> Ptr SCROLLINFO -> BOOL -> IO BOOL
+
+foreign import stdcall "windows.h GetScrollInfo" c_GetScrollInfo :: HWND -> Int32 -> Ptr SCROLLINFO -> IO Int32
+
+setScrollInfo wnd bar si = withSCROLLINFO si $ \p -> c_SetScrollInfo wnd bar p True
+
+getScrollInfo wnd bar = withSCROLLINFO (SCROLLINFO sIF_ALL 0 0 0 0 0) $ \p -> do
+	c_GetScrollInfo wnd bar p
+	readSCROLLINFO p
+
+data SCROLLINFO = SCROLLINFO { fMask :: Word32, nMin :: Int32, nMax :: Int32, nPage :: Word32, nPos :: Int32, nTrackPos :: Int32 } deriving (Eq, Show)
+
+withSCROLLINFO :: SCROLLINFO -> (Ptr SCROLLINFO -> IO t) -> IO t
+withSCROLLINFO si f = do
+	fp <- mallocForeignPtrBytes 28
+	withForeignPtr fp $ \p -> do 
+		pokeByteOff p 0 (28 :: Word32)
+		pokeByteOff p 4 (fMask si)
+		pokeByteOff p 8 (nMin si)
+		pokeByteOff p 12 (nMax si)
+		pokeByteOff p 16 (nPage si)
+		pokeByteOff p 20 (nPos si)
+		pokeByteOff p 24 (nTrackPos si)
+		f p
+
+readSCROLLINFO :: Ptr SCROLLINFO -> IO SCROLLINFO
+readSCROLLINFO p = do
+	fMask <- peekByteOff p 4
+	nMin <- peekByteOff p 8
+	nMax <- peekByteOff p 12
+	nPage <- peekByteOff p 16
+	nPos <- peekByteOff p 20
+	nTrackPos <- peekByteOff p 24
+	return (SCROLLINFO fMask nMin nMax nPage nPos nTrackPos)
+
+sB_HORZ :: Int32
+sB_HORZ = 0
+
+sB_VERT :: Int32
+sB_VERT = 1
+
+sB_CTL :: Word32
+sB_CTL = 2
+
+sIF_ALL :: Word32
+sIF_ALL = 31
+
+sB_PAGEDOWN :: Word32
+sB_PAGEDOWN = 3
+
+sB_PAGEUP :: Word32 
+sB_PAGEUP = 2
+
+sB_LINEUP :: Word32
+sB_LINEUP = 0
+
+sB_LINEDOWN :: Word32
+sB_LINEDOWN = 1
+
+sB_BOTTOM :: Word32
+sB_BOTTOM = 7
+
+sB_TOP :: Word32
+sB_TOP = 6
+
+sB_THUMBPOSITION :: Word32
+sB_THUMBPOSITION = 4
+
+sB_THUMBTRACK :: Word32
+sB_THUMBTRACK = 5
+
+loWord x = x .&. 65535
+
+hiWord x = shiftR x 16
+
+foreign import stdcall "windows.h CallWindowProcW" callWindowProc :: FunPtr WindowClosure -> HWND -> UINT -> WPARAM -> LPARAM -> IO LRESULT
+
+gWLP_WNDPROC :: Int32
+gWLP_WNDPROC = -4
+
+gWLP_WNDPARENT :: Int32
+gWLP_WNDPARENT = -8
+
+gWLP_ID :: Int32
+gWLP_ID = -12
+
+gWLP_USERDATA :: Int32
+gWLP_USERDATA = -21
+
+gWLP_STYLE :: Int32
+gWLP_STYLE = -16
+
+cB_ADDSTRING :: Word32
+cB_ADDSTRING = 323
+
+cB_GETCURSEL :: Word32
+cB_GETCURSEL = 327
+
+cB_SETCURSEL :: Word32
+cB_SETCURSEL = 334
+
+-- ...
+
+sIF_RANGE :: Word32
+sIF_RANGE = 1
+
+sIF_POS :: Word32
+sIF_POS = 2
+
+sIF_PAGE :: Word32
+sIF_PAGE = 4
+
+--------------------------------
+-- System colors
+
+foreign import stdcall "windows.h GetSysColorBrush" getSysColorBrush :: Word32 -> IO HBRUSH
+
+foreign import stdcall "windows.h GetSysColor" getSysColor :: Word32 -> IO Word32
+
+foreign import stdcall "windows.h GetDeviceCaps" getDeviceCaps :: HDC -> Int32 -> IO Int32
+
+lOGPIXELSX :: Int32
+lOGPIXELSX = 88
+
+lOGPIXELSY :: Int32
+lOGPIXELSY = 90
+
+dLGC_WANTCHARS :: Int32
+dLGC_WANTCHARS = 128
+
+dLGC_WANTARROWS :: Int32
+dLGC_WANTARROWS = 1
+
+dLGC_DEFPUSHBUTTON :: Int32
+dLGC_DEFPUSHBUTTON = 16
+
+wM_CTLCOLORSTATIC :: Word32
+wM_CTLCOLORSTATIC = 312
+
+------------------------------
+-- Threads
+
+foreign import stdcall "windows.h GetCurrentThreadId" getCurrentThreadId :: IO DWORD
+
+foreign import stdcall "windows.h PostThreadMessageW" postThreadMessage :: DWORD -> UINT -> WPARAM -> LPARAM -> IO Bool
+
+foreign import stdcall "windows.h MsgWaitForMultipleObjects" c_MsgWaitForMultipleObjects :: DWORD -> Ptr HANDLE -> Bool -> DWORD -> DWORD -> IO DWORD
+
+msgWaitForMultipleObjects :: [HANDLE] -> Bool -> DWORD -> DWORD -> IO DWORD
+msgWaitForMultipleObjects handles b n1 n2 = do
+	fp <- mallocForeignPtrBytes (4 * length handles)
+	withForeignPtr fp $ \p -> do
+		mapM_ (\(n, hdl) -> pokeByteOff p n hdl) (zip [0,4..] handles)
+		c_MsgWaitForMultipleObjects (fromIntegral $ length handles) p b n1 n2
+
+wAIT_TIMEOUT :: DWORD
+wAIT_TIMEOUT = 258
+
+pM_NOREMOVE :: DWORD
+pM_NOREMOVE = 0
+
+pM_REMOVE :: DWORD
+pM_REMOVE = 1
+
+pM_NOYIELD :: DWORD
+pM_NOYIELD = 2
+
+qS_ALLEVENTS :: DWORD
+qS_ALLEVENTS = 1215
+
+------------------------------
+-- Common dialog boxes
+
+foreign import stdcall "windows.h ChooseColorW" c_ChooseColor :: Ptr () -> IO Bool
+
+cC_ANYCOLOR :: Word32
+cC_ANYCOLOR = 256
+
+cC_FULLOPEN :: Word32
+cC_FULLOPEN = 2
+
+cC_PREVENTFULLOPEN :: Word32
+cC_PREVENTFULLOPEN = 4
+
+cC_RGBINIT :: Word32
+cC_RGBINIT = 1
+
+cC_SHOWHELP :: Word32
+cC_SHOWHELP = 8
+
+cC_SOLIDCOLOR :: Word32
+cC_SOLIDCOLOR = 128
+
+type CHOOSECOLOR = ()
+
+foreign import ccall "wrapper" mkFinalizer :: (Ptr a -> IO ()) -> IO (FinalizerPtr a)
+
+allocaChooseColor :: Word32 -> Word32 -> IO (ForeignPtr CHOOSECOLOR)
+allocaChooseColor clr flags = do
+	hdl <- getModuleHandle Nothing
+	cc <- mallocForeignPtrBytes 36
+	p2 <- mallocBytes 64
+	withForeignPtr cc $ \p -> do
+		pokeByteOff p 0 (36 :: Word32)
+		pokeByteOff p 4 (0 :: Word32)
+		pokeByteOff p 8 hdl
+		pokeByteOff p 12 clr
+		pokeByteOff p 16 p2
+		pokeByteOff p 20 flags
+		pokeByteOff p 24 (0 :: Word32)
+		pokeByteOff p 28 (0 :: Word32)
+		pokeByteOff p 32 (0 :: Word32)
+	fin <- mkFinalizer (\_ -> free p2)
+	addForeignPtrFinalizer fin cc
+	return cc
+
+-- | Open a choose colour dialog. Use 'allocaChooseColor' to create the parameter structure.
+chooseColor :: HWND -> ForeignPtr CHOOSECOLOR -> IO (Maybe COLORREF)
+chooseColor wnd fp = do
+	withForeignPtr fp $ \p -> do
+		b <- c_ChooseColor p
+		if b then do
+				clr <- peekByteOff p 12
+				return (Just clr)
+			else
+				return Nothing
+
+type OPENFILENAME = ()
+
+foreign import stdcall "windows.h GetOpenFileNameW" getOpenFileName :: Ptr OPENFILENAME -> IO Bool
+
+foreign import stdcall "windows.h GetSaveFileNameW" getSaveFileName :: Ptr OPENFILENAME -> IO Bool
+
+oFN_ALLOWMULTISELECT :: Word32
+oFN_ALLOWMULTISELECT = 512
+
+oFN_CREATEPROMPT :: Word32
+oFN_CREATEPROMPT = 8192
+
+oFN_DONTADDTORECENT :: Word32
+oFN_DONTADDTORECENT =  33554432
+
+oFN_EXPLORER :: Word32
+oFN_EXPLORER = 524288
+
+oFN_FILEMUSTEXIST :: Word32
+oFN_FILEMUSTEXIST = 4096
+
+oFN_HIDEREADONLY :: Word32
+oFN_HIDEREADONLY = 4
+
+oFN_OVERWRITEPROMPT :: Word32
+oFN_OVERWRITEPROMPT = 2
+--etc..
+
+data Action = Open | Save deriving Eq
+
+-- | Open or save a file.
+fileOpenOrSave :: Action -> HWND -> String -> String -> IO (Maybe String)
+fileOpenOrSave action wnd filter extension = do
+	hdl <- getModuleHandle Nothing
+	fp <- mallocForeignPtrBytes 76
+	fp2 <- mallocForeignPtrBytes 1000
+	withForeignPtr fp $ \p ->
+		withForeignPtr fp2 $ \p2 ->
+		withTString filter $ \flt ->
+		withTString extension $ \ext -> do
+		pokeByteOff p2 0 (0 :: Word16)
+		pokeByteOff p 0 (76 :: Word32)
+		pokeByteOff p 4 wnd
+		pokeByteOff p 8 hdl
+		pokeByteOff p 12 flt
+		pokeByteOff p 16 nullPtr
+		pokeByteOff p 24 (1 :: Word32)
+		pokeByteOff p 28 p2
+		pokeByteOff p 32 (1000 :: Word32)
+		pokeByteOff p 36 nullPtr
+		pokeByteOff p 44 nullPtr
+		pokeByteOff p 48 nullPtr
+		pokeByteOff p 52 (oFN_EXPLORER .|. if action == Open then oFN_FILEMUSTEXIST else oFN_OVERWRITEPROMPT)
+		pokeByteOff p 60 ext
+		b <- (if action == Open then getOpenFileName else getSaveFileName) p
+		if b then do
+				liftM Just (peekTString p2)
+			else
+				return Nothing
+
+fileOpen = fileOpenOrSave Open
+
+fileSave = fileOpenOrSave Save
+
+-- | Display a message box. This fixes the Win32 package MessageBox.
+messageBox' :: HWND -> String -> String -> MBStyle -> IO MBStatus
+messageBox' wnd text caption style =
+  withTString text $ \ c_text ->
+  withTString caption $ \ c_caption ->
+  failIfZero "MessageBox" $ c_MessageBox' wnd c_text c_caption style
+foreign import stdcall safe "windows.h MessageBoxW"
+  c_MessageBox' :: HWND -> LPCTSTR -> LPCTSTR -> MBStyle -> IO MBStatus
+
+------------------------------
+-- Printing
+
+foreign import stdcall "windows.h GlobalUnlock" globalUnlock' :: HANDLE -> IO Bool
+
+foreign import stdcall "windows.h OpenPrinterW" openPrinter :: LPTSTR -> Ptr HANDLE -> Ptr () -> IO Bool
+
+foreign import stdcall "windows.h DocumentPropertiesW" documentProperties :: HWND -> HANDLE -> LPTSTR -> Ptr () -> Ptr () -> Word32 -> IO LONG
+
+foreign import stdcall "windows.h CreateDCW" createDC :: LPCTSTR -> LPCTSTR -> LPCSTR -> Ptr () -> IO HDC
+
+foreign import stdcall "windows.h StartDocW" startDoc :: HDC -> Ptr () -> IO Int32
+
+foreign import stdcall "windows.h EndDoc" endDoc :: HDC -> IO Int32
+
+foreign import stdcall "windows.h StartPage" startPage :: HDC -> IO Int32
+
+foreign import stdcall "windows.h EndPage" endPage :: HDC -> IO Int32
+
+foreign import stdcall "windows.h ClosePrinter" closePrinter :: HANDLE -> IO Bool
+
+foreign import stdcall "windows.h GetDefaultPrinterW" getDefaultPrinter :: LPTSTR -> Ptr DWORD -> IO Bool
+
+dM_OUT_BUFFER :: Word32
+dM_OUT_BUFFER = 2
+
+dM_IN_PROMPT :: Word32
+dM_IN_PROMPT = 4
+-- etc..
+
+foreign import stdcall "windows.h PostMessageW" postMessage :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO Bool
+
+eN_GETSEL :: Word32
+eN_GETSEL = 176
+
+eN_SETSEL :: Word32
+eN_SETSEL = 177
+
+eN_UPDATE :: Word32
+eN_UPDATE = 1024
+
+cBN_EDITUPDATE :: Word32
+cBN_EDITUPDATE = 6
+
+cBN_SELENDOK :: Word32
+cBN_SELENDOK = 9
+
+lBN_SELCHANGE :: Word32
+lBN_SELCHANGE = 1
+
+bN_PUSHED :: Word32
+bN_PUSHED = 2
+
+bN_CLICKED :: Word32
+bN_CLICKED = 0
+
+hTBOTTOM :: Word32
+hTBOTTOM = 15
+
+hTBOTTOMLEFT :: Word32
+hTBOTTOMLEFT = 16
+
+hTBOTTOMRIGHT :: Word32
+hTBOTTOMRIGHT = 17
+
+hTCAPTION :: Word32
+hTCAPTION = 2
+
+hTLEFT :: Word32
+hTLEFT = 10
+
+hTRIGHT :: Word32
+hTRIGHT = 11
+
+hTTOP :: Word32
+hTTOP = 12
+
+hTTOPLEFT :: Word32
+hTTOPLEFT = 13
+
+hTTOPRIGHT :: Word32
+hTTOPRIGHT = 14
+
+hTCLOSE :: Word32
+hTCLOSE = 20
+
+hTMAXBUTTON :: Word32
+hTMAXBUTTON = 9
+
+hTMINBUTTON :: Word32
+hTMINBUTTON = 8
+
+foreign import stdcall "windows.h SetCapture" setCapture :: HWND -> IO HWND
+
+foreign import stdcall "windows.h ReleaseCapture" releaseCapture :: IO Bool
+
+sS_OWNERDRAW :: Word32
+sS_OWNERDRAW = 13
+
+foreign import stdcall "windows.h EnableWindow"
+  enableWindow' :: HWND -> Bool -> IO Bool
+
+------------------------------
+-- Menus
+
+-- | Fixes TrackPopupMenu to supply the selection as a return value.
+foreign import stdcall "windows.h TrackPopupMenu" trackPopupMenu' :: HMENU -> UINT -> LONG -> LONG -> LONG -> HWND -> Ptr RECT -> IO LONG
+
+------------------------------
+-- Common controls
+
+wC_LISTVIEW = "SysListView32"
+
+lVS_REPORT :: Word32
+lVS_REPORT = 1
+
+lVS_SINGLESEL :: Word32
+lVS_SINGLESEL = 4
+
+wC_TREEVIEW = "SysTreeView32"
+
+lVM_FIRST :: Word32
+lVM_FIRST = 4096
+
+lVM_GETITEMCOUNT = lVM_FIRST + 4
+
+lVM_DELETEITEM = lVM_FIRST + 8
+
+lVM_INSERTITEM = lVM_FIRST + 77
+
+lVM_GETITEMSTATE = lVM_FIRST + 44
+
+lVM_GETITEMTEXT = lVM_FIRST + 45
+
+lVM_SETITEMTEXT = lVM_FIRST + 116
+
+lVM_GETCOLUMN = lVM_FIRST + 95
+
+lVM_DELETECOLUMN = lVM_FIRST + 28
+
+lVM_INSERTCOLUMN = lVM_FIRST + 97
+
+lVM_SETCOLUMN = lVM_FIRST + 26
+
+lVIF_STATE :: Word32
+lVIF_STATE = 8
+
+lVIF_TEXT :: Word32
+lVIF_TEXT = 1
+
+lVCF_TEXT :: Word32
+lVCF_TEXT = 4
+
+lVCF_WIDTH :: Word32
+lVCF_WIDTH = 2
+
+lVIS_SELECTED :: Word32
+lVIS_SELECTED = 2
+
+tVM_FIRST :: Word32
+tVM_FIRST = 4352
+
+tVM_INSERTITEM = tVM_FIRST + 50
+
+tVM_DELETEITEM = tVM_FIRST + 1
+
+tVM_GETNEXTITEM = tVM_FIRST + 10
+
+tVM_GETITEM = tVM_FIRST + 62
+
+tVM_SETITEM = tVM_FIRST + 63
+
+tVGN_NEXT :: Word32
+tVGN_NEXT = 1
+
+tVGN_CHILD :: Word32
+tVGN_CHILD = 4
+
+tVIF_TEXT :: Word32
+tVIF_TEXT = 1
+
+tVIF_HANDLE :: Word32
+tVIF_HANDLE = 16
+
+tVS_HASLINES :: Word32
+tVS_HASLINES = 2
+
+foreign import stdcall "windows.h InitCommonControls" initCommonControls :: IO ()
+
+foreign import stdcall "windows.h TranslateAccelerator" translateAccelerator :: HGLOBAL -> HWND -> LPMSG -> IO Bool
+
+foreign import stdcall "windows.h GetWindowLongW" c_GetWindowLong :: HWND -> LONG -> IO LONG
+
+type LPCTBBUTTON = Ptr ()
+
+tb_addbuttons_size :: UINT
+tb_addbuttons_size = 20
+
+tB_ADDBITMAP :: UINT
+tB_ADDBITMAP = wM_USER + 19
+
+tB_ADDBUTTONSA :: UINT
+tB_ADDBUTTONSA = wM_USER + 20
+
+tB_INSERTBUTTONA :: UINT
+tB_INSERTBUTTONA = wM_USER + 21
+
+tB_DELETEBUTTON :: UINT
+tB_DELETEBUTTON = wM_USER + 22
+
+tB_REPLACEBITMAP :: UINT
+tB_REPLACEBITMAP = wM_USER + 46
+
+tB_BUTTONSTRUCTSIZE :: UINT
+tB_BUTTONSTRUCTSIZE = wM_USER + 30
+
+tB_SETBUTTONSIZE :: UINT
+tB_SETBUTTONSIZE = wM_USER + 31
+
+tB_SETBITMAPSIZE  :: UINT
+tB_SETBITMAPSIZE = wM_USER + 32
+
+tB_AUTOSIZE :: UINT
+tB_AUTOSIZE = wM_USER + 33
+
+tB_BUTTONCOUNT :: UINT
+tB_BUTTONCOUNT = wM_USER + 24
+
+tB_SETIMAGELIST :: UINT
+tB_SETIMAGELIST = wM_USER + 48
+
+tB_GETTOOLTIPS :: UINT
+tB_GETTOOLTIPS = wM_USER + 35
+
+tB_SETTOOLTIPS :: UINT
+tB_SETTOOLTIPS = wM_USER + 36
+
+foreign import stdcall "mmsystem.h timeBeginPeriod" timeBeginPeriod :: UINT -> IO UINT
+
+foreign import stdcall "mmsystem.h timeEndPeriod" timeEndPeriod :: UINT -> IO UINT
+
+foreign import stdcall "mmsystem.h timeSetEvent" timeSetEvent :: UINT -> UINT -> LPVOID -> UINT -> UINT -> IO UINT
+
+foreign import stdcall "windows.h CreateEventW" createEvent :: LPVOID -> BOOL -> BOOL -> LPTSTR -> IO HANDLE
+
+tIMER_ONESHOT :: UINT
+tIMER_ONESHOT = 1
+
+tIMER_PERIODIC :: UINT
+tIMER_PERIODIC = 64
+
+tIME_CALLBACK_FUNCTION :: UINT
+tIME_CALLBACK_FUNCTION = 0
+
+tIME_CALLBACK_EVENT_SET :: UINT
+tIME_CALLBACK_EVENT_SET = 16
+
+tIME_CALLBACK_EVENT_PULSE :: UINT
+tIME_CALLBACK_EVENT_PULSE = 32
+
+--- The following functions are utilities, not part of the Win32 API.
+
+-- | Helper to add buttons from a bitmap already present.
+{-
+addExistingBitmaps :: HWND -> [(LONG, UINT, BYTE)] -> IO ()
+addExistingBitmaps toolbar whichbuttons = do
+	let nButtons = length whichbuttons
+	fp <- mallocForeignPtrBytes (8 `max` (nButtons * tb_addbuttons_size))
+	withForeignPtr fp $ \p -> do
+		mapM_ (\(i, (n, id, state)) -> do
+			pokeByteOff p i n
+			pokeByteOff p (i + 4) id
+			pokeByteOff p (i + 8) 0
+			pokeByteOff (castPtr p) (i + 8) state
+			pokeByteOff p (i + 16) 0)
+			whichbuttons
+		sendMessage toolbar tB_ADDBUTTONSA nButtons (toLPARAM p)
+		sendMessage toolbar tB_AUTOSIZE 0 0
+
+addButtonsFromModule :: HINSTANCE -> HWND -> HRESOURCE -> [(LONG, UINT, BYTE)] -> IO ()
+addButtonsFromModule mod toolbar bitmap whichbuttons = do
+	sendMessage toolbar tB_BUTTONSTRUCTSIZE tb_addbuttons_size 0
+	fp <- mallocForeignPtrBytes 8
+	withForeignPtr fp $ \p => do
+		pokeByteOff p 0 mod
+		pokeByteoff p 4 bitmap
+		sendMessage toolbar tB_ADDBITMAP (maximum whichbuttons + 1) (toLPARAM p)
+	addExistingButtons toolbar whichbuttons	clearToolbar
+
+-- | Add buttons to a toolbar directly out of a resource. The elements of the third
+--   parameter indicate for each button, its position in the bitmap, its control ID,
+--   and its button state respectively.
+addButtons :: HWND -> HRESOURCE -> [(LONG, UINT, BYTE)] -> IO ()
+addButtons toolbar bitmap whichbuttons = do
+	mod <- getModuleHandle nullPtr
+	addButtonsFromModule mod toolbar bitmap whichbuttons
+
+-- | Remove all buttons from a toolbar.
+clearToolbar toolbar = whileM_ (return ()) (liftM (/=0) $ sendMessage toolbar tB_DELETEBUTTON 0 0)
+
+-- | Add toolbar buttons from an imagelist. Returns the former imagelist.
+setImageList :: HWND -> HIMAGELIST -> [(LONG, UINT, BYTE)] -> IO HIMAGELIST
+setImageList toolbar imagelist whichbuttons = do
+	sendMessage toolbar tB_BUTTONSTRUCTSIZE tb_addbuttons_size 0
+	clearToolbar toolbar
+	oldlist <- sendMessage toolbar tS_SETIMAGELIST 0 imagelist
+	addExistingButtons toolbar whichbuttons
+	return oldlist-}
+
+-- | Create a frame window with reasonable defaults. A null background brush is used to prevent flicker.
+frameWindow icon menu parent title closure = do
+ 	hdl <- getModuleHandle Nothing
+	cursor <- loadCursor Nothing iDC_ARROW
+	null <- getStockBrush nULL_BRUSH
+	let name = mkClassName "Frame"
+	registerClass (0, hdl, icon, Just cursor, Just null, Nothing, name)
+	createWindowEx 0 name title (wS_OVERLAPPEDWINDOW .|. wS_VISIBLE .|. wS_CLIPCHILDREN) Nothing Nothing Nothing Nothing Nothing menu parent closure
+