diff --git a/CHANGES b/CHANGES
--- a/CHANGES
+++ b/CHANGES
@@ -1,60 +1,102 @@
-Version 1.2:
-* Renamed "Upd" to "Act" in Monad.hs
-* Added "commandNews" in Imperative.hs
-* Tweaked for compatibility with TypeCompose-0.1
+% [Phooey](http://haskell.org/haskellwiki/Phooey) changes
 
-Version 1.1:
-* Added src/Examples/Applicative.hs.  I'd accidentally omitted it.
-* Imperative.hs: renamed "mkNews" to "commandNews" and added a more
-  general function called "mkNews".
+== Version 1.4 ==
 
-Version 1.0:
-* Uses new TypeCompose package, which includes a simple implementation of
-  data-driven computation.
-* New Applicative functor interface.
-* Eliminated the catch-all Phooey.hs module.  Now import any one of
-  Graphics.UI.Phooey.{Monad,Applicative,Arrow}.  
-* renamed "textEntry" to "stringEntry"
-* added "isliderDisplay"
-* Phooey.Monad has two different styles of output widgets, made by owidget
-  and owidget'.  The latter is used to implement Phooey.Applicative.
-* Self- and mutually-recursive widgets now work again in Phooey.Monad.
-  They still hang in Phooey.Arrow.
+* Exposed a few more functions
+* WinEvents: motion' and motionDiff' carry key modifiers (shift, control, etc)
+* Menu-related functions in WinEvents
+* wxHaskell attributes as Pair
+* Several tests for events & sources: t1, ...
+* Changed examples to track Event/Source changes, especially with accumulation.
+* Calculator now shows keys pressed as well as result
+* Optional debugging output for mouse events.
 
-Version 0.3.1:
-* Fixed dos-style line breaks in src/MonadExamples.hs
-* Fixed Functor UI def (broke the circularity)
+## Version 1.3 ##
 
-Version 0.3:
-* Finished renaming "CallbackT" to "CallBackT" (thanks to Michal Palka for
-  catching the inconsistency).
-* Renamed AmA.hs to AFA.hs.  AFA is more general in that it works with
-  applicative functors instead of monads.
-* ArrowUI.title now defined in terms of ArrowMonad.title.
-* Added src/MonadExamples.hs
-* Changed type of MonadUI.runUI.  Now takes a UI (Source ()) instead of UI
-  ().  The new type is more convenient for use.
-* Relaxed type of LayoutT.runL, to accommodate the new MonadUI.runUI type.
-* Makefile tweaks to fit cabal-make changes.
+This version is mostly a simplification and sync'ing with changes to
+DataDriven (previously part of TypeCompose) and TV.
 
-Version 0.2.1:
-* Changed all files to *nix-style line endings.
++  Several new examples in Examples.Monad, including the classic
+   calculator.
++  Removed modules `TagT`,`LayoutT` and `Arrow` from `Graphics.UI.Phooey`.
++  Removed `Examples.Arrow`.
++  Simplified `Phooey.Monad`.
++  Removed `isliderDyn` & examples, for simplicity.  I'd like to find more
+   compelling examples of dynamic UIs and recursive UIs.
++  Replaced `title` functions with `title` method from `Title` class in
+   [TypeCompose].
++  Fixed [Examples.Applicative](src/Examples/Applicative.hs).
++  Added [WinEvents](src/Graphics/UI/Phooey/WinEvents.hs): with high-level
+   interfaces to [wxHaskell] events.
 
-Changes in version 0.2:
+## Version 1.2 ##
 
-* Finally fixed a long-standing stretching bug.  When widgets are abutted
-  horizontally, they now all stretch together.
++  Renamed "Upd" to "Act" in Monad.hs
++  Added "commandNews" in Imperative.hs
++  Tweaked for compatibility with [TypeCompose] 0.1
 
-Changes in version 0.1:
+## Version 1.1 ##
 
-* Web-located references to other libraries (base, mtl, arrows.)
-* Colorized source code links (thanks to hscolour).
-* "User Comments", for adding add comments and questions.
-* New home (wiki) page: http://haskell.org/haskellwiki/Phooey
-* Switched from monadLib to mtl, for easier installation
-* Added this "CHANGES" file
-* Text input (textEntry)
-* Fixed all of the module intro comments
-* Boolean input/output (checkBoxEntry, checkBoxDisplay)
-* runNamedUI for explicit window title (rather "Phooey GUI")
-* Phooey is now used in TV: http://haskell.org/haskellwiki/Phooey .
++  Added [Examples.Applicative](src/Examples/Applicative.hs).  I'd
+   accidentally omitted it.
++  In [Imperative](src/Graphics/UI/Phooey/Imperative.hs): renamed "mkNews"
+   to "commandNews" and added a more general function called "mkNews".
+
+## Version 1.0 ##
+
++  Uses new TypeCompose package, which includes a simple implementation of
+   data-driven computation.
++  New Applicative functor interface.
++  Eliminated the catch-all Phooey.hs module.  Now import any one of
+   Graphics.UI.Phooey.{Monad,Applicative,Arrow}.  
++  renamed "textEntry" to "stringEntry"
++  added "isliderDisplay"
++  Phooey.Monad has two different styles of output widgets, made by owidget
+   and owidget'.  The latter is used to implement Phooey.Applicative.
++  Self- and mutually-recursive widgets now work again in Phooey.Monad.
+   They still hang in Phooey.Arrow.
+
+## Version 0.3.1 ##
+
++  Fixed dos-style line breaks in src/MonadExamples.hs
++  Fixed Functor UI def (broke the circularity)
+
+## Version 0.3 ##
+
++  Finished renaming "CallbackT" to "CallBackT" (thanks to Michal Palka for
+   catching the inconsistency).
++  Renamed AmA.hs to AFA.hs.  AFA is more general in that it works with
+   applicative functors instead of monads.
++  ArrowUI.title now defined in terms of ArrowMonad.title.
++  Added src/MonadExamples.hs
++  Changed type of MonadUI.runUI.  Now takes a UI (Source ()) instead of UI
+   ().  The new type is more convenient for use.
++  Relaxed type of LayoutT.runL, to accommodate the new MonadUI.runUI type.
++  Makefile tweaks to fit cabal-make changes.
+
+## Version 0.2.1 ##
+
++  Changed all files to *nix-style line endings.
+
+## Version 0.2 ##
+
++  Finally fixed a long-standing stretching bug.  When widgets are abutted
+   horizontally, they now all stretch together.
+
+## Version 0.1 ##
+
++  Web-located references to other libraries (base, mtl, arrows.)
++  Colorized source code links (thanks to hscolour).
++  "User Comments", for adding add comments and questions.
++  New home (wiki) page: http://haskell.org/haskellwiki/Phooey
++  Switched from monadLib to mtl, for easier installation
++  Added this "CHANGES" file
++  Text input (textEntry)
++  Fixed all of the module intro comments
++  Boolean input/output (checkBoxEntry, checkBoxDisplay)
++  runNamedUI for explicit window title (rather "Phooey GUI")
++  Phooey is now used in TV: http://haskell.org/haskellwiki/Phooey .
+
+
+[TypeCompose]: http://haskell.org/haskellwiki/TypeCompose
+[wxHaskell]:   http://haskell.org/haskellwiki/wxHaskell
diff --git a/Makefile b/Makefile
--- a/Makefile
+++ b/Makefile
@@ -1,9 +1,9 @@
 # For special configuration, especially for docs.  Otherwise see README.
 
-haddock-interfaces=\
-  http://haskell.org/ghc/docs/latest/html/libraries/base,c:/ghc/ghc-6.6/doc/html/libraries/base/base.haddock \
-  http://haskell.org/ghc/docs/latest/html/libraries/mtl,c:/ghc/ghc-6.6/doc/html/libraries/mtl/mtl.haddock \
-  http://darcs.haskell.org/packages/TypeCompose/doc/html,c:/Haskell/packages/TypeCompose-0.1/doc/html/TypeCompose.haddock \
-  http://wxhaskell.sourceforge.net/doc,c:/Haskell/wxhaskell/out/doc/wxhaskell.haddock
+# haddock-interfaces=\
+#   http://haskell.org/ghc/docs/latest/html/libraries/base,c:/ghc/ghc-6.6/doc/html/libraries/base/base.haddock \
+#   http://haskell.org/ghc/docs/latest/html/libraries/mtl,c:/ghc/ghc-6.6/doc/html/libraries/mtl/mtl.haddock \
+#   http://darcs.haskell.org/packages/TypeCompose/doc/html,c:/Haskell/packages/TypeCompose-0.2/doc/html/TypeCompose.haddock \
+#   http://wxhaskell.sourceforge.net/doc,c:/Haskell/wxhaskell/out/doc/wxhaskell.haddock
 
 include ../my-cabal-make.inc
diff --git a/Setup.lhs b/Setup.lhs
--- a/Setup.lhs
+++ b/Setup.lhs
@@ -1,3 +1,3 @@
-#!/usr/bin/env runhaskell
-> import Distribution.Simple
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
 > main = defaultMain
diff --git a/TODO b/TODO
--- a/TODO
+++ b/TODO
@@ -0,0 +1,11 @@
+% [Phooey](http://haskell.org/haskellwiki/Phooey) To Do
+
++ Even out the stretching between sub-layouts.  I nest binary layout
+  operators, and I think the stretch space is divided in two each time.
+  Look for *associative* layout operators.  I may have to make my own
+  layout data type that holds lists of layouts, so I can append them.
+  Right now, I just make rows, columns, boxed, and widget (with fill), so
+  the data type could reflect those tools.
+
++ Consider rewriting `Phooey.Monad` to use mtl-style operations instead of
+  working on `UI'`.
diff --git a/phooey.cabal b/phooey.cabal
--- a/phooey.cabal
+++ b/phooey.cabal
@@ -1,5 +1,5 @@
 Name:                phooey
-Version:             1.2
+Version:             1.4
 Synopsis: 	     Functional user interfaces
 Category:            User Interfaces
 Description:
@@ -33,17 +33,13 @@
 Stability:           provisional
 Hs-Source-Dirs:      src
 Extensions:          CPP, Arrows
-Build-Depends:       base, mtl, arrows, TypeCompose>=0.1, wx, wxcore
+Build-Depends:       base, array, mtl, wx, wxcore, TypeCompose>=0.2, DataDriven
 Exposed-Modules:     
+                     Graphics.UI.Phooey.WinEvents
                      Graphics.UI.Phooey.Imperative
-                     Graphics.UI.Phooey.TagT
-                     Graphics.UI.Phooey.LayoutT
                      Graphics.UI.Phooey.Monad
                      Graphics.UI.Phooey.Applicative
-                     Graphics.UI.Phooey.Arrow
 Extra-Source-Files:
-                     Examples.Imperative
                      Examples.Monad
                      Examples.Applicative
-                     Examples.Arrow
 ghc-options:         -O -Wall
diff --git a/src/Examples/Applicative.hs b/src/Examples/Applicative.hs
--- a/src/Examples/Applicative.hs
+++ b/src/Examples/Applicative.hs
@@ -1,172 +1,57 @@
-{-# OPTIONS #-}
-
-----------------------------------------------------------------------
--- |
--- Module      :  Examples.Applicative
--- Copyright   :  (c) Conal Elliott 2007
--- License     :  LGPL
--- 
--- Maintainer  :  conal@conal.net
--- Stability   :  experimental
--- Portability :  portable
--- 
--- Applicative-style Phooey examples.  Use 'runUI'
-----------------------------------------------------------------------
-
-module Examples.Applicative where
-
-import Control.Applicative
-import Control.Monad.Fix (fix)
-
-import Graphics.UI.Phooey.Applicative
-
--- For oPair etc
-import Control.DataDriven (Sink,Updater)
-import Data.Monoid
-
-h :: UI String
-h = pure "Hello World!"
-
-sl0 :: IWidget Int
-sl0 = islider (0,10)
-
-uia,uib :: UI Upd
-uia = stringDisplay <*> h
-uib = showDisplay <*> sl0 3
-
-
-ui1 :: UI Upd
-ui1 = title "Shopping List" $ fruit <**> total
-
-apples, bananas, fruit :: UI Int
-apples  = title "apples"  (sl0 3)
-bananas = title "bananas" (sl0 7)
-
-fruit = liftA2 (+) apples bananas
-
--- With overloading, we could say
--- fruit = apples + bananas
-
-total :: Num a => OWidget a
-total = title "total" showDisplay
-
-
-pair :: Applicative f => f a -> f b -> f (a,b)
-pair = liftA2 (,)
-
-lo,hi :: UI Int
-lo = title "lo" $ sl0 2
-hi = title "hi" $ sl0 8
-
-val :: UI Int
-val = title "val" $ isliderDyn (pair lo hi) 5
-
--- Note that the "val" title is around the lo & hi sliders as well.  I
--- guess that layout reflects the purpose of the lo & hi sliders.  I don't
--- know how to get a "val" title on just the dynamically-bounded slider.
-ui2 :: UI Upd
-ui2 = (fact <$> val) <**> title "factorial" showDisplay
-
--- minor variation
-ui2' = val <**>
-       pure fact <**>
-       title "factorial" showDisplay
-
--- Variation
-
-fact :: Int -> Int
-fact n = product [1 .. n]
-
-
-o1 :: UI (Snk (Int -> Int -> Int))
-o1 = oLambda apples (oLambda bananas total)
-
-ui4 :: UI Upd
-ui4 = o1 <*> pure (+)
-
--- Experiments.  None of these functions is specific to UI
-
--- iPair :: Applicative ui => ui a -> ui b -> ui (a,b)
--- iPair = liftA2 (,) -- fromLeft
-
--- oPair :: (Applicative ui, Applicative src, Monoid (Updater src))
---       => ui (Sink src a) -> ui (Sink src b) -> ui (Sink src (a,b))
--- oPair = liftA2 oPair'  -- fromLeft
-
--- -- Suggested use: m = src ()
--- oLambda :: Applicative ui
---         => ui a -> ui (b -> m) -> ui ((a->b) -> m)
--- oLambda = liftA2 oLambda'  -- fromTop
-
--- -- Monoid variant for oPair
-
--- oPairM :: (Applicative ui, Monoid m)
---        => ui (a -> m) -> ui (b -> m) -> ui ((a,b) -> m)
--- oPairM = liftA2 oPairM'
-
--- oPairM' :: Monoid m => (a -> m) -> (b -> m) -> ((a,b) -> m)
--- oPairM' oa ob (a,b) = oa a `mappend` ob b  -- fromLeft
-
-iPair :: UI a -> UI b -> UI (a,b)
-iPair a b = fromLeft (liftA2 (,) a b)
-
-oPair :: (Monoid (Updater src), Applicative src)  -- e.g., src == IO
-      => UI (Sink src a) -> UI (Sink src b) -> UI (Sink src (a,b))
-oPair a b = fromLeft (liftA2 oPair' a b)
-
-oPair' :: (Monoid (Updater src), Applicative src)
-       => Sink src a -> Sink src b -> Sink src (a,b)
-oPair' oa ob (a,b) = oa a `mappend` ob b
-
--- Suggested use: m = src ()
-oLambda :: UI a -> UI (b -> m) -> UI ((a->b) -> m)
-oLambda a b = fromTop (liftA2 oLambda' a b)
-
-oLambda' :: a -> (b -> m) -> ((a->b) -> m)
-oLambda' ia ob f = ob (f ia)
-
-
-o2 :: UI (Snk ((Int,Int) -> Int))
-o2 = oLambda (iPair apples bananas) total
-
-ui5 :: UI Upd
-ui5 = o2 <*> pure (uncurry (+))
-
-o3 :: UI (Snk ((Int,Int) -> (Int,Int))) 
-o3 = oLambda (iPair sli sli) (oPair slo slo)
- where
-   sli = sl0 5
-   slo = isliderDisplay (0,10)
-
-ui6 :: UI Upd
-ui6 = o3 <*> pure (\ (a,b) -> (b,a))
-
-
----- Recursive:
-
--- ffix :: Functor f => f (a->a) -> f a
--- ffix = fmap fix
-
--- or
--- ffix :: (m a -> m a) -> m a
--- ffix = fix
-
-unPair :: Functor f => f (a, b) -> (f a, f b)
-unPair p = (fmap fst p, fmap snd p)
-
-ui7 :: UI (Int,Int)
-ui7 = fix f
- where f :: UI (Int,Int) -> UI (Int,Int)
-       f bounds = liftA2 (,)
-                    (isliderDyn (pair (pure  0) hi) 3)
-                    (isliderDyn (pair lo (pure 10)) 8)
-        where
-          ~(lo,hi) = unPair bounds
-
-ui8 :: UI Upd
-ui8 = total <*> fmap (uncurry (+)) ui7
-
-ui9 :: UI Upd
-ui9 = fix f *> pure mempty
- where f :: UI Int -> UI Int
-       f val = isliderDyn (pair ((subtract 5) <$> val) ((+ 5) <$> val)) 10
+----------------------------------------------------------------------
+-- |
+-- Module      :  Examples.Applicative
+-- Copyright   :  (c) Conal Elliott 2007
+-- License     :  LGPL
+-- 
+-- Maintainer  :  conal@conal.net
+-- Stability   :  experimental
+-- Portability :  portable
+-- 
+-- Applicative-style Phooey examples.  Use 'runUI'
+----------------------------------------------------------------------
+
+module Examples.Applicative where
+
+import Control.Applicative
+import Data.Monoid
+
+-- TypeCompose
+import Data.Title
+-- DataDriven
+import Data.Source
+
+import Graphics.UI.Phooey.Applicative
+
+h :: UI String
+h = pure "Hello World!"
+
+sl0 :: IWidget Int
+sl0 = islider (0,10)
+
+uia,uib :: UI Action
+uia = stringDisplay <*> h
+uib = showDisplay <*> sl0 3
+
+
+ui1 :: UI Action
+ui1 = title "Shopping List" $ fruit <**> total
+
+apples, bananas, fruit :: UI Int
+apples  = title "apples"  (sl0 3)
+bananas = title "bananas" (sl0 7)
+
+fruit = liftA2 (+) apples bananas
+
+-- With Num overloading, we could say
+-- fruit = apples + bananas
+
+total :: Num a => OWidget a
+total = title "total" showDisplay
+
+
+sqrt1 :: UI Action
+sqrt1 = (sqrt <$> i) <**> o
+ where
+   i = title "x"  $ fslider (0,10) (3 :: Float)
+   o = title "square root" $ fsliderDisplay (0,4)
diff --git a/src/Examples/Arrow.hs b/src/Examples/Arrow.hs
deleted file mode 100644
--- a/src/Examples/Arrow.hs
+++ /dev/null
@@ -1,116 +0,0 @@
-{-# OPTIONS -fglasgow-exts -farrows #-}
-----------------------------------------------------------------------
--- |
--- Module      :  Examples.Arrow
--- Copyright   :  (c) Conal Elliott 2006
--- License     :  LGPL
--- 
--- Maintainer  :  conal@conal.net
--- Stability   :  experimental
--- Portability :  portable
--- 
--- Phooey examples.  Run them with 'runUI'
-----------------------------------------------------------------------
-
-module Examples.Arrow where
-
-import Control.Arrow
-import Graphics.UI.Phooey.Arrow
-
--- Simple shopping list
-
-sl0 :: IWidget Int
-sl0 = islider (0,10)
-
-ui1 :: UI () ()
-ui1 =  title "Shopping List" $
-       proc () -> do
-         a  <- title "apples"   $ sl0 3 -< ()
-         b  <- title "bananas"  $ sl0 7 -< ()
-         title "total"  showDisplay     -< a+b
-
-
-lo,hi :: UI () Int
-lo = title "lo" (sl0 3)
-hi = title "hi" (sl0 8)
-
--- Dynamic bounds
-ui2 = proc () -> do
-        l <- lo -< ()
-        h <- hi -< ()
-        v <- title "val" $ isliderDyn 5 -< (l,h)
-        title "factorial" showDisplay   -< fact v
-
-bounds :: UI () (Int,Int)
-bounds = lo &&& hi
-
-bounds' = proc () -> do 
-            l <- lo -< ()
-            h <- hi -< ()
-            returnA -< (l,h)
-          
-
-val :: UI () Int
-val = title "val" $ (lo &&& hi) >>> isliderDyn 5
-
-val' = bounds >>> title "val" (isliderDyn 5)
-
-ui2' = val' >>> pure fact >>> title "factorial" showDisplay
-
-ui2'' = (fact ^<< val') >>> title "factorial" showDisplay
-
-
-fact n = product [1 .. n]
-
-
--- In the two examples above, visual layout is implicitly chosen to be
--- top-down, following the order in which the components are declared in
--- the arrow expressions.  This choice may be overridden, as in the
--- following examples.
-
-uiB1  = fromBottom  ui1
-uiL1  = fromLeft    ui1
-uiR1  = fromRight   ui1
-
-ui3 =  fromBottom $
-       proc () -> do
-	    (a,b) <- fromRight fruit   -< (0,10)
-	    title "total" showDisplay  -< a+b
-  where       
-   fruit =  title "apples"   (isliderDyn 3) &&&
-	    title "bananas"  (isliderDyn 7)
-
-
--- Recursive examples.  These ones just hang.  Investigate.
-
-
-uir1 = proc () -> do
-         rec  lo   <-  title "lo"   (isliderDyn 3)  -< (0,hi)
-              hi   <-  title "hi"   (isliderDyn 8)  -< (lo,10)
-              val  <-  title "val"  (isliderDyn 5)  -< (lo,hi)
-              title "factorial" showDisplay         -< fact val
-         returnA -< ()
-
-uir2 = proc () -> do
-         rec  val <- title "val" (isliderDyn 6)  -< (val-5,val+5)
-         title "squared" showDisplay             -< val*val
-
-uir3 = proc () -> do
-         s  <- title "message" (stringEntry "")  -< ()
-         title "reversed" stringDisplay   -< reverse s
-
-
--- -- Simpler example for testing
--- uia = proc () -> do
---         n <- sl0 5 -< ()
---         showDisplay           -< fact n
-
--- uia' = fromLeft uia
-
--- uib :: UI () ()
--- uib =  title "Shopping List" $
---        proc () -> do
---          a  <- title "apples"   (sl0 3) -< ()
---          b  <- title "bananas"  (sl0 7) -< ()
---          title "sum"      showDisplay              -< a+b
---          title "product"  showDisplay              -< a*b
diff --git a/src/Examples/Examples.hs b/src/Examples/Examples.hs
--- a/src/Examples/Examples.hs
+++ b/src/Examples/Examples.hs
@@ -1,21 +1,21 @@
-{-# OPTIONS #-}
-
-----------------------------------------------------------------------
--- |
--- Module      :  Examples.Examples
--- Copyright   :  (c) Conal Elliott 2007
--- License     :  LGPL
--- 
--- Maintainer  :  conal@conal.net
--- Stability   :  experimental
--- Portability :  portable
--- 
--- Imports example modules for easy error-checking
-----------------------------------------------------------------------
-
-module Examples.Examples where
-
-import qualified Examples.Imperative as Imp
-import qualified Examples.Monad as Mon
-import qualified Examples.Applicative as App
-import qualified Examples.Arrow as Arr
+{-# OPTIONS #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      :  Examples.Examples
+-- Copyright   :  (c) Conal Elliott 2007
+-- License     :  LGPL
+-- 
+-- Maintainer  :  conal@conal.net
+-- Stability   :  experimental
+-- Portability :  portable
+-- 
+-- Imports example modules for easy error-checking
+----------------------------------------------------------------------
+
+module Examples.Examples where
+
+-- import qualified Examples.Imperative as Imp
+import qualified Examples.Monad as Mon
+import qualified Examples.Applicative as App
+-- import qualified Examples.Arrow as Arr
diff --git a/src/Examples/Imperative.hs b/src/Examples/Imperative.hs
deleted file mode 100644
--- a/src/Examples/Imperative.hs
+++ /dev/null
@@ -1,70 +0,0 @@
-{-# OPTIONS #-}
-
-----------------------------------------------------------------------
--- |
--- Module      :  Examples.Imperative
--- Copyright   :  (c) Conal Elliott 2007
--- License     :  LGPL
--- 
--- Maintainer  :  conal@conal.net
--- Stability   :  experimental
--- Portability :  portable
--- 
--- Imperative Phooey examples
-----------------------------------------------------------------------
-
-module Examples.Imperative where
-
-import Graphics.UI.Phooey.Imperative
-
-import Graphics.UI.WX
-
-
-runUI0  ::  IO ()
-runUI0  = start $
-  do  f      <- frame [ visible := False, text := "ui0" ]
-      pan    <- panel f  []
-      count  <- hslider pan True 0 10 [ selection := 3 ]
-      countSub <- mkNews count
-      double <- textEntry pan [ ]
-      triple <- textEntry pan [ ]
-      
-      let updDouble = do  n <- get count selection
-                          set double [ text := show (2*n) ]
-      let updTriple = do  n <- get count selection
-                          set triple [ text := show (3*n) ]
-      countSub updDouble
-      countSub updTriple
-      updDouble
-      updTriple
-      set pan  [  layout :=
-                   boxed "Shopping List" $
-                   fill $ column 0
-                     [  lhwidget "count"   count
-                     ,  lhwidget "double"  double  {-""-}
-                     ,  lhwidget "triple"  triple    ]  ]
-      set f    [ layout := hwidget pan, visible := True ]
-
-runUI1  ::  IO ()
-runUI1  = start $
-  do  f        <- frame [ visible := False, text := "ui1" ]
-      pan      <- panel f  []
-      apples   <- hslider pan True 0 10 [ selection := 3 ]
-      newsA    <- mkNews apples
-      bananas  <- hslider pan True 0 10 [ selection := 7 ]
-      newsB    <- mkNews bananas
-      total    <- textEntry pan [ ]
-      let updTot = do  a  <- get apples selection
-                       b  <- get bananas selection
-                       set total [ text := show (a+b) ]
-      newsA updTot
-      newsB updTot
-      updTot
-      set pan  [  layout :=
-                   boxed "Shopping List" $
-                   fill $ column 0
-                     [  lhwidget "apples"   apples
-                     ,  lhwidget "bananas"  bananas  {-""-}
-                     ,  lhwidget "total"    total    ]  ]
-      set f    [ layout := hwidget pan, visible := True ]
-
diff --git a/src/Examples/Monad.hs b/src/Examples/Monad.hs
--- a/src/Examples/Monad.hs
+++ b/src/Examples/Monad.hs
@@ -1,5 +1,8 @@
-{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE TypeSynonymInstances, RecursiveDo #-}
+-- For ghc 6.6 compatibility
+-- {-# OPTIONS -fglasgow-exts #-}
 
+
 ----------------------------------------------------------------------
 -- |
 -- Module      :  Examples.Monad
@@ -8,152 +11,404 @@
 -- 
 -- Maintainer  :  conal@conal.net
 -- Stability   :  experimental
--- Portability :  portable
+-- Portability :  RecursiveDo
 -- 
--- Monadic-style Phooey examples.  Use 'runUI'
+-- Monadic-style Phooey examples.  Use 'runUI' or 'runNamedUI'.
 ----------------------------------------------------------------------
 
 module Examples.Monad where
 
 import Control.Applicative
-import Control.Monad (liftM2)
-import Control.Monad.Fix
-import Data.Monoid (mappend,mempty)
+import Data.Monoid
+import Char (isDigit,ord)
+import Maybe (fromJust)
 
+import System.Time
+
+-- mtl
+import Control.Monad.Trans
+
+-- wxHaskell
+import Graphics.UI.WX hiding (Event,(.+.),key,button,smallButton,row)
+import qualified Graphics.UI.WX as WX
+
+-- TypeCompose
+import Control.Compose (Unop,Binop)
+import Data.Title
+
+-- DataDriven
+import Data.Event
+import Data.Source
+
+-- Phooey
 import Graphics.UI.Phooey.Monad
 
+{----------------------------------------------------------
+    Simplest examples
+----------------------------------------------------------}
 
--- h :: UI (Source String)
--- h = return (pure "Hello World!")
+h :: UIS String
+h = return (pure "Hello World!")
 
--- uia,uib :: UI (Source ())
--- uia = stringDisplay =<< h
--- uib = showDisplay =<< sl0 3
+strs :: UIS String
+strs = choices (words "Make things as simple as possible but not simpler") "simple"
 
+strsU :: UI ()
+strsU = stringDisplay =<< strs 
 
-ui1 :: UI (Source ())
-ui1 = title "Shopping List" $
-      do a <- title "apples"  $ islider (0,10) 3
-         b <- title "bananas" $ islider (0,10) 7
-         title "total" $ showDisplay (liftA2 (+) a b)
+strLen :: UI ()
+strLen = do str <- strs
+            showDisplay (fmap length str)
 
--- Refactoring
+uia,uib :: UI ()
+uia = stringDisplay =<< h
+uib = showDisplay   =<< islider (0,10) 3
 
+shopping1 :: UI ()
+shopping1 = title "Shopping List" $
+            do a <- title "apples"  $ islider (0,10) 3
+               b <- title "bananas" $ islider (0,10) 7
+               title "total" $ showDisplay (liftA2 (+) a b)
+
+area1 :: UI ()
+area1 = do w <- title "width"  $ fslider (0,10) (3 :: Float)
+           h <- title "height" $ fslider (0,10) 7
+           title "area" $ showDisplay (liftA2 (*) w h)
+
+sqrt1 :: UI ()
+sqrt1 = do x <- title "x"  $ fslider (0,10) (3 :: Float)
+           title "square root" $ fsliderDisplay (0,4) (sqrt <$> x)
+
+
+---- Refactoring
+
 sl0 :: IWidget Int
 sl0 = islider (0,10)
 
-apples, bananas :: UI (Source Int)
+apples, bananas :: UIS Int
 apples  = title "apples"  $ sl0 3
 bananas = title "bananas" $ sl0 7
 
 total :: Num a => OWidget a
 total = title "total" . showDisplay
 
-ui1x :: UI (Source ())
-ui1x = title "Shopping List" $
-       do a <- apples
-          b <- bananas
-          total (liftA2 (+) a b)
+shopping2 :: UI ()
+shopping2 = title "Shopping List" $
+            do a <- apples
+               b <- bananas
+               total (liftA2 (+) a b)
 
-fruit :: UI (Source Int)
-fruit = liftM2 (liftA2 (+)) apples bananas
+-- Sum UIs
+infixl 6  .+.
 
-ui1y :: UI (Source ())
-ui1y = title "Shopping List" $ fruit >>= total
+(.+.) :: Num a => UIS a -> UIS a -> UIS a
+(.+.) = liftA2 (liftA2 (+))
 
+fruit :: UIS Int
+fruit = apples .+. bananas
 
+shopping3 :: UI ()
+shopping3 = title "Shopping List" $ fruit >>= total
+
+-- Small variation: title the fruit instead of the total
+shopping3' :: UI ()
+shopping3' = title "Shopping List" fruit >>= total
+
 -- In the two examples above, visual layout is implicitly chosen to be
 -- top-down, following the order in which the components are declared in
 -- the arrow expressions.  This choice may be overridden, as in the
 -- following examples.
 
-uiB1  = fromBottom  ui1
-uiL1  = fromLeft    ui1
-uiR1  = fromRight   ui1
+shoppingB  = fromBottom  shopping3
+shoppingL  = fromLeft    shopping3
+shoppingR  = fromRight   shopping3
 
+-- Mix & match layout
+shopping4 = fromBottom $
+            title "Shopping  List" $
+            fromRight fruit >>= total
 
-ui3 = fromBottom $
-      title "Shopping  List" $
-      fromRight fruit >>= total
 
+{----------------------------------------------------------
+    Subtotals -- suggested by Mads Lindstroem
+----------------------------------------------------------}
 
--- Experiments with multiple displays
-uix = do n <- sl0 3
-         liftM2 mappend
-                (showDisplay (liftA (*2) n))
-                (showDisplay (liftA (*3) n))
+-- more items
+shovels, rakes, tools :: UIS Int
+shovels = title "shovels" $ sl0 2
+rakes   = title "rakes"   $ sl0 5
+tools   = shovels .+. rakes
 
--- Dynamic
+basket1 :: UI ()
+basket1 = title "Shopping List" $
+          do f          <- fruit
+             title "Fruit"  $ showDisplay f
+             t          <- tools
+             title "Tools"  $ showDisplay t
+             title "Basket" $ showDisplay $ liftA2 (+) f t
 
-ui2 :: UI (Source ())
-ui2 = do  l <- title "lo"    $ sl0 3
-          h <- title "hi"    $ sl0 8
-          v <- title "val"   $ isliderDyn (pair l h) 5
-          title "factorial"  $ showDisplay (liftA fact v)
+-- Abstract out the pattern above.  Display and pass along an
+-- "intermediate result", following an idea of Mads.
+ir :: Show a => String -> UIS a -> UIS a
+ir str ui = do x <- ui
+               title str $ showDisplay x
+               return x
 
-fact :: Int -> Int
-fact n = product [1 .. n]
+-- with ir
+basket2 :: UI ()
+basket2 = title "Shopping List" $
+          do f <- ir "Fruit" fruit
+             t <- ir "Tools" tools
+             title "Basket" $ showDisplay $ liftA2 (+) f t
 
--- Refactor
+-- refactored
+basket3 :: UI ()
+basket3 = title "Shopping List" $
+          ir "Fruit" fruit .+. ir "Tools" tools
+          >>= title "Basket" . showDisplay
 
-lo,hi :: UI (Source Int)
-lo = title "lo" $ sl0 3
-hi = title "hi" $ sl0 8
+-- A handy pattern: vertical arrangement with title & subtotal.
+subtotal :: Show a => String -> UIS a -> UIS a
+subtotal ttl ui = fromTop $ title ttl $ ir "subtotal" ui
 
-bounds :: UI (Source (Int,Int))
-bounds = liftM2 pair lo hi
+-- Place shopping sub-lists and grand total alongside each other
+basket4 :: UI ()
+basket4 = title "Shopping List" $
+          fromLeft $ subtotal "Fruit" fruit .+. subtotal "Tools" tools
+          >>= title "Grand total" . showDisplay
 
-val :: UI (Source Int)
-val = do b <- bounds
-         title "val" $ isliderDyn b 5
 
--- Alternative style, in which the "val" title is around the lo & hi
--- sliders as well.  This layout reflects the purpose of the lo & hi
--- sliders.
+{----------------------------------------------------------
+    Classic up/down counter example.  See
+    <http://haskell.org/haskellwiki/Phooey#Counter>
+----------------------------------------------------------}
 
-val' = title "val" $
-       do b <- bounds
-          isliderDyn b 5
+-- Value-changer.  Increment on "up" & decrement on "down"
+upDown :: Num a => UIE (a -> a)
+upDown = smallButton (+1) "up" `mappend` smallButton (subtract 1) "down"
 
-ui2' = do v <- val'
-          title "factorial"  $ showDisplay (liftA fact v)
+upDown' :: Num a => UIE (a -> a)
+upDown' = do up   <- smallButton (+1)         "up"
+             down <- smallButton (subtract 1) "down"
+             return (up `mappend` down)
 
+-- The counter.
+counter :: UI ()
+counter = title "Counter" $ fromLeft $
+          do e <- upDown
+             -- Apply each increment/decrement cumulatively
+             0 `accumS` e >>= showDisplay
 
--- Recursive
+-- Note: I could purely accumulate the @a -> a@, and even do so very
+-- elegantly as the endomorphism monoid ('Endo'), so as not to have to
+-- specify the identity ('mempty') and composition ('mappend').  Whenever the
+-- endomorphism changes, it would get applied to the initial value, which
+-- would be frightfully expensive.  In a sense, the approach above
+-- exploits associativity of composition for efficiency.
+-- 
+-- Mitch Wand used this associativity trick very effectively in his paper
+-- "Continuation-Based Program Transformation Strategies".  He also came
+-- up with alternative representations for the continuations.  Oh!  I
+-- could do that here.  The continuation is adding a number.  Use the
+-- 'Sum' monoid instead of 'Endo', and we'll have an efficient, evaluated
+-- representation of that continuation, namely a single number to be
+-- added.
 
-uir1 :: UI (Source ())
-uir1 = mdo l <- title "lo"   $ isliderDyn (pair (pure 0) h) 3
-           h <- title "hi"   $ isliderDyn (pair l (pure 10)) 8
-           v <- title "val"  $ isliderDyn (pair l h) 5
-           title "factorial" $ showDisplay (liftA fact v)
+upDown2 :: Num a => UIE (Sum a)
+upDown2 = smallButton (Sum 1) "up" `mappend` smallButton (Sum (-1)) "down"
 
--- Refactor
+counter2 :: UI ()
+counter2 = title "Counter" $ fromLeft $
+           do ud <- upDown2
+              n  <- (fmap.fmap) getSum (monoidS ud)
+              showDisplay n
 
-boundsR :: UI (Source (Int,Int))
-boundsR = mfix boundsF
- where
-   boundsF lh = liftM2 pair
-                  (title "lo" $ isliderDyn (pair (pure 0) h) 3)
-                  (title "hi" $ isliderDyn (pair l (pure 10)) 8)
-     where
-       (l,h) = unPair lh
 
-unPair :: Functor f => f (a, b) -> (f a, f b)
-unPair p = (fmap fst p, fmap snd p)
+{----------------------------------------------------------
+    Calculator, from "Lightweight GUIs for Functional Programming".
+    See <http://haskell.org/haskellwiki/Phooey#Calculator>
+----------------------------------------------------------}
 
-valR :: UI (Source Int)
-valR = do b <- boundsR
-          title "val" $ isliderDyn b 5
+-- Single calculator key
+key :: Char -> UIE Char
+key c = button' c [ outerSize := sz 50 50, text := [c] ]
 
-uir1' = do v <- valR
-           title "factorial"  $ showDisplay (liftA fact v)
+-- Handy
+mconcatMap :: Monoid b => (a -> b) -> [a] -> b
+mconcatMap f = mconcat . map f
 
+-- Row of keys.  Uses the Monoid instances for UI and Event 
+row :: [Char] -> UIE Char
+row = fromLeft . mconcatMap key
 
-uir2 = mdo v <- title "val" (isliderDyn (liftA (plusMinus 5) v) 6)
-           title "squared" (showDisplay (liftA square v))
+-- Rows of keys.
+rows :: [[Char]] -> UIE Char
+rows = fromTop . mconcatMap row
+
+-- The whole keyboard.  Four rows of four keys each
+calcKeys :: UIE Char
+calcKeys =  rows [ "123+"
+                 , "456-"
+                 , "789*"
+                 , "C0=/" ]
+
+
+-- Test calcKeys, accumulating the string of keys pressed.  Each char c
+-- gets replaced by (c :), which get successively applied via 'accumS'.
+testKeys :: UI ()
+testKeys = title "Calculator key test" $
+           calcKeys >>= showKeys
+              
+showKeys :: Event Char -> UI ()
+showKeys key =
+  do chars <- "" `accumS` fmap (:) key
+     title "keys pressed" $ stringDisplay $ fmap reverse chars
+
+-- -- Test calcKeys, accumulating the string of keys pressed.  Each char c
+-- -- gets replaced by (c :), which get successively applied via 'accumS'.
+-- testKeys :: UI ()
+-- testKeys = title "Calculator key test" $
+--            do key <- calcKeys
+--               chars <- "" `accumS` fmap (:) key
+--               title "chars" $ stringDisplay $ fmap reverse chars
+
+
+-- The calculator state is a number being formed and a continuation.
+type CState = (Int, Unop Int)
+
+-- Start state
+startCS :: CState
+startCS = (0, id)
+
+-- Interpret a character as a state transition.
+cmd :: Char -> Unop CState
+cmd 'C' _                 = startCS
+cmd '=' (d,k)             = (k d, const (k d))
+cmd  c  (d,k) | isDigit c = (10*d + ord c - ord '0', k)
+              | otherwise = (0, op c (k d))
+
+-- TODO: Try formulating the state as a monoid.  Use Endo for the
+-- continuation and for the state transition.
+
+-- Operation associated with a key
+op :: Char -> Binop Int
+op c = fromJust (lookup c ops)
  where
-   plusMinus n x = (x-n,x+n)
-   square y      = y*y
+   ops :: [(Char, Binop Int)]
+   ops =  [('+',(+)), ('-',(-)), ('*',(*)), ('/',div)]
 
-pair :: Applicative f => f a -> f b -> f (a,b)
-pair = liftA2 (,)
+-- The calculator
+calc :: UI ()
+calc = title "Calculator" $
+       do key <- calcKeys
+          showKeys key
+          showCalc key
+
+showCalc :: Event Char -> UI ()
+showCalc key = do states <- startCS `accumS` fmap cmd key
+                  title "result" $ showDisplay $ fmap fst states
+
+-- -- The calculator
+-- calc :: UI ()
+-- calc = title "Calculator" $
+--        do e <- calcF
+--           states <- startCS `accumS` e
+--           title "result" $ showDisplay $ fmap fst states
+
+
+---- Redo with monoids
+
+-- With the @String@ monoid
+testKeys2 :: UI ()
+testKeys2 = title "Calculator key test - monoid version" $
+            do key <- calcKeys
+               str <- monoidS (fmap (:[]) key)
+               title "chars" $ stringDisplay str
+
+-- Hm.  I think the strings get combined in the worst possible way, by
+-- repeated snoc'ing, which is probably on the same order as the Endo
+-- composition.
+
+-- With the @Endo CState@ monoid
+calc2 :: UI ()
+calc2 = title "Calculator - monoid version" $
+        do key  <- calcKeys
+           endos <- monoidS (fmap (Endo . cmd) key)
+           let n = fmap (fst . ($ startCS) . appEndo) endos
+           title "result" $ showDisplay n
+
+-- As mentioned above, I expect this @calc2@ to be very wasteful,
+-- accumulating and re-applying longer & longer composition chains as it
+-- goes.  Applying Mitch Wand's lovely trick, what's a data representation
+-- for the subset of @CState -> CState@ that comes from compositions of
+-- @cmd@?
+
+
+-- Timed polling
+
+calendarTime :: Double -> UI (Source CalendarTime)
+calendarTime secs = timedPoll secs (getClockTime >>= toCalendarTime)
+
+clock :: UI ()
+clock = (fmap.fmap) calendarTimeToString (calendarTime 1) >>= stringDisplay
+
+
+---- Tests: move to Test.hs
+
+{----------------------------------------------------------
+    Tests
+----------------------------------------------------------}
+
+test = mapM_ runUI [t0,t1,t2,t3,t4,t5,t6]
+
+-- basic counter
+t0 = do up <- button (+1) "up"
+        n <- 0 `accumS` up
+        showDisplay n
+
+-- "up" only works the first time
+t1 = do up <- button (+1) "up"
+        n <- 0 `accumS` once up
+        showDisplay n
+
+-- "up" works until "stop"
+t2 = do stop <- button () "stop"
+        up   <- button (+1) "up"
+        n    <- 0 `accumS` (up `before` stop)
+        showDisplay n
+
+-- two buttons: each increments
+t3 = do poke <- button () "poke me"
+        dont <- button () "don't poke me"
+        ec   <- countE (poke `mappend` dont)
+        n    <- 0 `stepper` ec
+        showDisplay n
+
+-- different rendering of t0
+-- TODO: rewrite accumS this way.  or explain why not.
+t4 = do up <- button (+1) "up"
+        ec <- 0 `accumE` up
+        n <- 0 `stepper` ec
+        showDisplay n
+
+-- up/down
+t5 = do up   <- button (+1)         "up"
+        down <- button (subtract 1) "down"
+        ec   <- 0 `accumE` (up `mappend` down)
+        n    <- 0 `stepper` ec
+        showDisplay n
+
+-- value pairs
+t6 = do up <- button (+1) "up"
+        e  <- 0 `accumE` up
+        showDisplay =<< 0 `stepper` e
+        e' <- withPrevE e
+        showDisplay =<< (10,10) `stepper` e'
+
+-- prime withPrev with 0
+t7 = do up <- button (+1) "up"
+        e  <- 0 `accumE` up
+        showDisplay =<< 0 `stepper` e
+        e' <- withPrevE (pure 0 `mappend` e)
+        showDisplay =<< (10,10) `stepper` e'
+
diff --git a/src/Graphics/UI/Phooey/Applicative.hs b/src/Graphics/UI/Phooey/Applicative.hs
--- a/src/Graphics/UI/Phooey/Applicative.hs
+++ b/src/Graphics/UI/Phooey/Applicative.hs
@@ -1,4 +1,6 @@
-{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE TypeSynonymInstances, TypeOperators #-}
+-- For ghc 6.6 compatibility
+-- {-# OPTIONS -fglasgow-exts #-}
 
 ----------------------------------------------------------------------
 -- |
@@ -8,7 +10,7 @@
 -- 
 -- Maintainer  :  conal@conal.net
 -- Stability   :  experimental
--- Portability :  portable
+-- Portability :  TypeSynonymInstances
 -- 
 -- UIs as applicative functors.  This module is a very simple layering
 -- over "Graphics.UI.Phooey.Monad".  It serves to hide the 'Source' types
@@ -18,27 +20,31 @@
 module Graphics.UI.Phooey.Applicative
   (
   -- * The UI applicative functor
-    UI, runUI, runNamedUI, Act, Snk
+    UI, runUI, runNamedUI, Action, Sink
   -- * Tools for high-level widgets
-  , IWidget, OWidget
+  , IWidget, OWidget, iwidget, owidget
   -- * Some high-level widgets
   , stringEntry, stringDisplay, showDisplay
-  , islider, isliderDyn, isliderDisplay
-  , checkBoxEntry, checkBoxDisplay
-  , title
+  , islider, isliderDisplay
+  , fslider, fsliderDisplay
+  , checkBoxEntry, checkBoxDisplay, choices, timedPoll, cache
   -- * Explicit layout
   , fromTop, fromBottom, fromLeft, fromRight, flipLayout
   ) where
 
-import Control.Monad.Reader
-import Control.Applicative
+-- Base
+import Control.Applicative (pure)
+
+-- TypeCompose
 import Control.Compose
+import Data.Title
 
-import Graphics.UI.Phooey.LayoutT
-import Graphics.UI.Phooey.TagT
+-- DataDriven
+import Data.Event (Action,Sink)
+import Data.Source (Source)
 
+-- Phooey
 import qualified Graphics.UI.Phooey.Monad as M
-import Graphics.UI.Phooey.Monad (Source,Act,Snk)
 
 
 {----------------------------------------------------------
@@ -46,15 +52,17 @@
 ----------------------------------------------------------}
 
 -- | The UI applicative functor.
-type UI = O M.UI Source
+type UI = M.UI :. Source
 
--- | Run a 'UI' with window title \"Monadic Phooey GUI\".
-runUI :: UI Act -> IO ()
+-- | Run a 'UI' with window title \"Applicative Phooey GUI\".
+runUI :: UI Action -> IO ()
 runUI = runNamedUI "Applicative Phooey GUI"
 
 -- | Run a 'UI' with given window title.
-runNamedUI :: String -> UI Act -> IO ()
-runNamedUI name = M.runNamedUI' name . unO
+runNamedUI :: String -> UI Action -> IO ()
+runNamedUI name =
+  -- convert the @UI (Source Action)@ to a @UI ()@ and run.
+  M.runNamedUI name . M.act . unO
 
 
 {----------------------------------------------------------
@@ -65,7 +73,7 @@
 type IWidget a = a -> UI a
 
 -- | Output widget.  Yields a sink of values
-type OWidget a = UI (Snk a)
+type OWidget a = UI (Sink a)
 
 -- | Make an input widget
 iwidget :: M.IWidget a -> IWidget a
@@ -73,7 +81,7 @@
 
 -- | Make an output widget
 owidget :: M.OWidget' a -> OWidget a
-owidget mwid = O (fmap pure mwid)
+owidget = O . fmap pure
 
 
 {----------------------------------------------------------
@@ -93,18 +101,21 @@
 showDisplay = owidget M.showDisplay'
 
 
--- | Slider input widget with static bounds
+-- | Slider input widget
 islider :: (Int,Int) -> IWidget Int
 islider bounds = iwidget (M.islider bounds)
 
+-- | Slider input widget over fractional values
+fslider :: RealFrac a => (a,a) -> IWidget a
+fslider bounds = iwidget (M.fslider bounds)
+
 -- | Slider output widget with static bounds
 isliderDisplay :: (Int,Int) -> OWidget Int
 isliderDisplay bounds = owidget (M.isliderDisplay' bounds)
 
--- | Slider widget with dynamic bounds.
-isliderDyn :: UI (Int,Int) -> IWidget Int
-isliderDyn (O bounds) initial = O $
-  bounds >>= flip M.isliderDyn initial
+-- | Slider input widget over fractional values
+fsliderDisplay :: RealFrac a => (a,a) -> OWidget a
+fsliderDisplay bounds = owidget (M.fsliderDisplay' bounds)
 
 -- | Boolean input widget
 checkBoxEntry :: IWidget Bool
@@ -114,39 +125,46 @@
 checkBoxDisplay :: OWidget Bool
 checkBoxDisplay = owidget M.checkBoxDisplay'
 
--- | Wrap a title around a 'UI'
-title :: String -> Unop (UI a)
-title str = inO (M.title str)
-            -- mapLayout (boxed str)
+-- | Input from a \"menu\" of choices.
+choices :: [String] -> IWidget String
+choices strings = iwidget (M.choices strings)
 
+-- | Input from a timer and a means of polling.  Interval is in seconds.
+-- If 'poll' is expensive, then apply 'cache' to the resulting UI.
+timedPoll :: Double -> IO a -> UI a
+timedPoll secs poll = O (M.timedPoll secs poll)
+
+-- | Cache a source, presumably with an expensive polling action
+cache :: UI a -> UI a
+cache = inO M.cache
+
+
+-- Wrap a title around a 'UI'
+instance Title_f UI where title_f str = inO (title_f str)
+
 {----------------------------------------------------------
     Layout
 ----------------------------------------------------------}
 
--- | Tweak the 'LayoutT'
-onLayoutT :: LayoutTOp IO -> Unop (UI a)
-onLayoutT f = inO (M.onLayoutT f)
-
 -- | Lay out from top to bottom
 fromTop :: Unop (UI a)
+fromTop = inO M.fromTop
 
 -- | Lay out from bottom to top
 fromBottom :: Unop (UI a)
+fromBottom = inO M.fromBottom
 
 -- | Lay out from left to right
 fromLeft :: Unop (UI a)
+fromLeft = inO M.fromLeft
 
 -- | Lay out from right to left
 fromRight :: Unop (UI a)
+fromRight = inO M.fromRight
 
 -- | Reverse layout
 flipLayout :: Unop (UI a)
-
-fromTop    = onLayoutT fromTopL
-fromBottom = onLayoutT fromBottomL
-fromLeft   = onLayoutT fromLeftL
-fromRight  = onLayoutT fromRightL
-flipLayout = onLayoutT flipL
+flipLayout = inO M.flipLayout
 
 
 -----
diff --git a/src/Graphics/UI/Phooey/Arrow.hs b/src/Graphics/UI/Phooey/Arrow.hs
deleted file mode 100644
--- a/src/Graphics/UI/Phooey/Arrow.hs
+++ /dev/null
@@ -1,138 +0,0 @@
-{-# OPTIONS -fglasgow-exts #-}
-
-----------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.Phooey.Arrow
--- Copyright   :  (c) Conal Elliott 2006
--- License     :  LGPL
--- 
--- Maintainer  :  conal@conal.net
--- Stability   :  provisional
--- Portability :  portable
--- 
--- A functional UI arrow.  See explanation and examples in
--- "Graphics.UI.Phooey".
-----------------------------------------------------------------------
-
-module Graphics.UI.Phooey.Arrow
-  ( 
-  -- * The UI arrow
-    UI(..), runUI, runNamedUI
-  -- * High-level widgets
-  , IWidget, OWidget
-  , stringDisplay, showDisplay, stringEntry, islider, isliderDyn
-  , checkBoxDisplay, checkBoxEntry, title
-  -- * Explicit layout
-  , fromTop, fromBottom, fromLeft, fromRight, flipLayout
-  -- * Internal (extensibility)
-  , ui, sourceOp, onLayoutT
-  ) where
-
-
-import Control.Arrow
-import Data.Monoid
-
-import Graphics.UI.Phooey.TagT (Unop)
-import Graphics.UI.Phooey.LayoutT
-import qualified Graphics.UI.Phooey.Monad as M
-
-import Control.Compose
-
-{----------------------------------------------------------
-    The UI arrow
-----------------------------------------------------------}
-
--- | The UI arrow
-newtype UI i o = UI ((ArrowAp (Kleisli M.UI) M.Source) i o)
-  deriving (Arrow,ArrowLoop)
-
--- | Run a 'UI' with window title \"Phooey Arrow GUI\".
-runUI :: UI () () -> IO ()
-runUI = runNamedUI "Phooey Arrow GUI"
-
--- | Run a 'UI' with given window title.
-runNamedUI :: String -> UI () () -> IO ()
-runNamedUI str (UI (ArrowAp (Kleisli f))) = M.runNamedUI str (f mempty)
-
--- runNamedUI str (UI (ArrowAp (Kleisli f))) = M.runNamedUI str (f mempty)
-
--- | Wrap up monadic UI function as a 'UI'
-ui :: (M.Source i -> M.UI (M.Source o)) -> UI i o
-ui = UI . ArrowAp . Kleisli
-
-
-{----------------------------------------------------------
-    High-level widgets
-----------------------------------------------------------}
-
--- | Input widget type (with initial value)
-type IWidget  a = a -> UI () a
--- | Output widget type
-type OWidget  a = UI a ()
-
--- | String display widget
-stringDisplay :: OWidget String
-stringDisplay = ui M.stringDisplay
-
--- | Showable display widget
-showDisplay :: Show a => OWidget a
-showDisplay = pure show >>> stringDisplay
-              -- or: ui M.showDisplay
-
--- | Simple text input widget
-stringEntry :: IWidget String
-stringEntry initial = ui (const (M.stringEntry initial))
-
--- | Slider widget with initial value and /static/ bounds (min,max)
-islider :: (Int,Int) -> IWidget Int
-islider bounds initial = ui (const (M.islider bounds initial))
-
--- | Slider widget with static initial value and /dynamic/ bounds (min,max)
-isliderDyn :: Int -> UI (Int,Int) Int
-isliderDyn initial = ui (flip M.isliderDyn initial)
-
--- | String display widget
-checkBoxDisplay :: UI Bool ()
-checkBoxDisplay = ui M.checkBoxDisplay
-
--- | Simple checkbox input widget
-checkBoxEntry :: Bool -> UI () Bool
-checkBoxEntry initial = ui (const (M.checkBoxEntry initial))
-
--- | Wrap a title around a 'UI'
-title :: String -> Unop (UI a b)
-title str = sourceOp (M.title str)
-
-
-{----------------------------------------------------------
-    Layout
-----------------------------------------------------------}
-
--- | Lay out from top to bottom
-fromTop :: Unop (UI a b)
-fromTop = onLayoutT fromTopL
-
--- | Lay out from bottom to top
-fromBottom :: Unop (UI a b)
-fromBottom = onLayoutT fromBottomL
-
--- | Lay out from left to right
-fromLeft :: Unop (UI a b)
-fromLeft = onLayoutT fromLeftL
-
--- | Lay out from right to left
-fromRight :: Unop (UI a b)
-fromRight = onLayoutT fromRightL
-
--- | Reverse layout
-flipLayout :: Unop (UI a b)
-flipLayout = onLayoutT flipL
-
-
----- Misc unexported
-
-sourceOp :: Unop (M.UI (M.Source b)) -> Unop (UI a b)
-sourceOp f (UI (ArrowAp (Kleisli g))) = ui (f . g)
-
-onLayoutT :: LayoutTOp IO -> Unop (UI a b)
-onLayoutT f = sourceOp (M.onLayoutT f)
diff --git a/src/Graphics/UI/Phooey/Imperative.hs b/src/Graphics/UI/Phooey/Imperative.hs
--- a/src/Graphics/UI/Phooey/Imperative.hs
+++ b/src/Graphics/UI/Phooey/Imperative.hs
@@ -1,5 +1,3 @@
-{-# OPTIONS #-}
-
 ----------------------------------------------------------------------
 -- |
 -- Module      :  Graphics.UI.Phooey.Imperative
@@ -16,7 +14,7 @@
 module Graphics.UI.Phooey.Imperative
   (
   -- * Widget & layout tools
-    hwidget,lhwidget ,hsliderDyn, mkNews, commandNews
+    above, leftOf, empty', hwidget,lhwidget ,hsliderDyn
   -- * Simple abstraction around widget containers and frames
   , Win, Wio, runWio
   )
@@ -25,26 +23,20 @@
 import Graphics.UI.WX
 import Graphics.UI.WXCore (sliderGetMin,sliderGetMax,sliderSetRange)
 
-import Data.IORef
-import Control.Monad (join)
-import Data.Monoid (mappend)
 import Control.Instances () -- For Monoid (IO a) instance
 
 {-----------------------------------------------------------------------
     Widget & layout tools
 -----------------------------------------------------------------------}
 
--- -- | Get the current 'selection' value of a widget
--- getSel :: Selection ctl => ctl -> IO Int
--- getSel ctl = get ctl selection
-
--- -- | Set a single attribute
--- set1 :: w -> Attr w a -> a -> IO ()
--- set1 w attr val = set w [ attr := val ]
+-- | Binary layout combinator
+above, leftOf :: Layout -> Layout -> Layout
+la `above`   lb = fill (column  0 [la,lb])
+la `leftOf`  lb = fill (row     0 [la,lb])
 
--- -- | Set the 'command' callback
--- onCommand :: Commanding ctl => ctl -> IO () -> IO ()
--- onCommand ctl io = set ctl [ on command := io ]
+-- | A stretchy empty layout
+empty' :: Layout
+empty' = fill empty
 
 -- | Horizontally-filled widget layout
 hwidget :: Widget w => w -> Layout
@@ -77,36 +69,15 @@
          when (lo <= x && x <= hi)
            (set ctl [ selection := x ])
 
--- | Make a \"news\" publisher given a function that (destructively) assigns
--- a single action to be executed upon some event.  The publisher can
--- remember any number of actions (the "subscribers").
-mkNews :: (IO () -> IO ()) -> IO (IO () -> IO ())
-mkNews setNotify = 
-  do  ref <- newIORef (return ())  -- contains subscribed actions
-      setNotify (join (readIORef ref))
-      return $ modifyIORef ref . mappend
 
--- | Make a \"news\" publisher for a widget's command.
-commandNews :: Commanding wid => wid -> IO (IO () -> IO ())
-commandNews wid = mkNews (\ act -> set wid [ on command := act ])
-
--- cmdNews wid = 
---     do -- putStrLn "mkNews"
---        ref <- newIORef (return ())  -- contains subscribed actions
---        set wid [ on command := join (readIORef ref) ]
---        return $ modifyIORef ref . mappend
-
--- TODO: perform action only when the value actually changes.  I get an
--- extra kick on grabbing a slider and two extra on releasing.  Is there a
--- way to eliminate them?
-
-
 {-----------------------------------------------------------------------
     Wio -- simple abstraction around widget containers and frames
 -----------------------------------------------------------------------}
 
-type Win  = Panel ()            -- ^ Container of widgets
-type Wio  = Win -> IO Layout    -- ^ Consumes container and yield layout
+-- | Container of widgets
+type Win  = Panel ()
+-- | Consumes container and yield layout
+type Wio  = Win -> IO Layout
 
 -- | Run a 'Wio': handle frame & widget creation, and apply layout.
 runWio :: String -> Wio -> IO ()
diff --git a/src/Graphics/UI/Phooey/LayoutT.hs b/src/Graphics/UI/Phooey/LayoutT.hs
deleted file mode 100644
--- a/src/Graphics/UI/Phooey/LayoutT.hs
+++ /dev/null
@@ -1,116 +0,0 @@
-{-# OPTIONS -fglasgow-exts #-}
-
-----------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.Phooey.LayoutT
--- Copyright   :  (c) Conal Elliott 2006
--- License     :  LGPL
--- 
--- Maintainer  :  conal@conal.net
--- Stability   :  provisional
--- Portability :  portable
--- 
--- A monad transformer for managing GUI layout.
--- Specializes 'TagT' to layouts as tag values.
-----------------------------------------------------------------------
-
-module Graphics.UI.Phooey.LayoutT
-  ( 
-  -- * The /layout manager/ monad transformer (or laid-out value makers)
-    LayoutT, runLayout, runL, LayoutTOp
-  -- * 'LayoutT' combinators
-  , flipL , fromTopL, fromBottomL, fromLeftL, fromRightL
-  -- , above, beside, fempty , setLayoutL
-  -- * Miscellany
-  , panelWrap
-  ) where
-
-import Data.Maybe (fromMaybe)
-import Graphics.UI.WX
-
-import Graphics.UI.Phooey.Imperative (Win, runWio)
-import Graphics.UI.Phooey.TagT
-
-{----------------------------------------------------------
-    /Layout manager/ monad transformer (or laid-out value makers)
-----------------------------------------------------------}
-
--- | /Layout manager/ monad transformer (or laid-out value maker)
-type LayoutT m = TagT Layout m
-
--- | /Run/ a 'LayoutT'.
-runLayout :: Monad m => LayoutT m a -> m (Layout,a)
-runLayout lt =
-  do  ~(mbl,a) <- runTag above lt
-      return (fromMaybe fempty mbl, a)
-
--- | Create a window, and run a 'LayoutT' in it.
-runL :: String -> (Win -> LayoutT IO (IO ())) -> IO ()
-runL name f = runWio name $ \ win -> 
-  do ~(l,upd) <- runLayout (f win)
-     upd
-     return l
-
-
-{----------------------------------------------------------
-    Layout combinators
-----------------------------------------------------------}
-
--- | Layout combiner
-type LayoutTOp m = TagTOp Layout m
-
--- | Identity for 'above' and 'beside'.
-fempty :: Layout
-fempty = fill empty
-
--- | Temporarily /replace/ the layout combiner
-setLayoutL  ::  Monad m => Binop Layout
-            ->  Unop (LayoutT m a)
-setLayoutL = setTagComb
-
-
--- | Lay out from top to bottom
-fromTopL :: Monad m => Unop (LayoutT m a)
-fromTopL = setLayoutL above
-
--- | Lay out from bottom to top
-fromBottomL :: Monad m => Unop (LayoutT m a)
-fromBottomL  = setLayoutL (flip above)
-
--- | Lay out from left to right
-fromLeftL :: Monad m => Unop (LayoutT m a)
-fromLeftL = setLayoutL beside
-
--- | Lay out from right to left
-fromRightL :: Monad m => Unop (LayoutT m a)
-fromRightL = setLayoutL (flip beside)
-
--- | Temporarily /reverse/ the layout combiner
-flipL :: Monad m => Unop (LayoutT m a)
-flipL = flipTagComb
-
-
--- Layout binops used above
-above, beside :: Binop Layout
-la  `above`   lb = fill (column  0 [la,lb])
-la  `beside`  lb = fill (row     0 [la,lb])
-
--- The following definitions are simpler, but they don't work!  I get
--- 'fromTopL' and 'fromLeftL', so it seems that 'flipTagComb' doesn't work.
-
--- fromBottomL  = flipL . fromTopL
--- fromRightL   = flipL . fromLeftL
-
-
-{----------------------------------------------------------
-    Miscellany
-----------------------------------------------------------}
-
--- | Wrap another panel and layout unop (probably id, hfill, vfill, or fill)
--- to get desired stretchiness.
-panelWrap :: Unop Layout -> Unop (Win -> IO (Maybe Layout, b))
-panelWrap layf f w = do  pan     <- panel w []
-                         ~(mbl,b) <- f pan
-                         -- if we get a layout, use it for the panel.
-                         maybe (return ()) (\ l -> set pan [ layout := l ]) mbl
-                         return (Just (layf (widget pan)), b)
diff --git a/src/Graphics/UI/Phooey/Monad.hs b/src/Graphics/UI/Phooey/Monad.hs
--- a/src/Graphics/UI/Phooey/Monad.hs
+++ b/src/Graphics/UI/Phooey/Monad.hs
@@ -1,5 +1,11 @@
-{-# OPTIONS -fglasgow-exts #-}
+{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleContexts
+           , UndecidableInstances, ScopedTypeVariables #-}
+-- For ghc 6.6 compatibility
+-- {-# OPTIONS -fglasgow-exts #-}
 
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+
 ----------------------------------------------------------------------
 -- |
 -- Module      :  Graphics.UI.Phooey.Monad
@@ -18,184 +24,192 @@
 module Graphics.UI.Phooey.Monad
   (
   -- * The UI monad
-   UI, Source, Act, Snk, runUI, runNamedUI, runUI', runNamedUI'
+   CxLayout, UI, UI', biUI, inUI, toUI, fromUI
+  , UIE, UIS
+  , runUI, runNamedUI, act
+  , accumE, accumS, monoidE, monoidS
   -- * Tools for high-level widgets
-  , IWidget, OWidget, OWidget', IOWidget, MkWidget
-  , iwidget, owidget, owidget', iowidget
+  , IWidget, OWidget, OWidget', IOWidget, MkWidget, widgetL
+  , iwidget, iwidget', owidget, owidget', iowidget
   -- * Some high-level widgets
   , stringEntry, stringDisplay, stringDisplay'
   , showDisplay, showDisplay'
-  , islider, isliderDyn, isliderDisplay, isliderDisplay'
+  , islider, isliderDisplay, isliderDisplay'
+  , fslider, fsliderDisplay, fsliderDisplay'
   , checkBoxEntry, checkBoxDisplay, checkBoxDisplay'
-  , title
+  , button, button', smallButton
+  , choices, timedPoll, cache
   -- * Explicit layout
   , fromTop, fromBottom, fromLeft, fromRight, flipLayout
-  -- * Misc tools
-  , mkWidget
-  , onLayoutT, mapLayout
   ) where
 
 import Control.Applicative
+import Control.Arrow ((>>>),first,second)
+import Data.Maybe (fromJust)
+import Data.List (elemIndex)
+
+-- mtl
 import Control.Monad.Reader
 import Control.Monad.Writer
-import Control.Arrow (first)
 
-import Graphics.UI.WX hiding (textEntry)
+-- wxHaskell
+import Graphics.UI.WX hiding (Event,button,smallButton)
 import qualified Graphics.UI.WX as WX
 
-import Control.Compose () -- for Monad (IO a) instance
-import Control.DataDriven
+-- TypeCompose
+import Control.Compose (Unop,(:.)(..))
+import Data.CxMonoid
+import Data.Bijection
+import Data.Title
 
-import Graphics.UI.Phooey.Imperative
-import Graphics.UI.Phooey.TagT (Unop,UUnop,mkTag,mapTag)
-import Graphics.UI.Phooey.LayoutT
+-- DataDriven
+import Data.Source
+import Data.Event
 
+-- Phooey
+import Graphics.UI.Phooey.Imperative (Win,empty',above,leftOf,hwidget)
+import Graphics.UI.Phooey.WinEvents (attrSource,getAttr,setAttr,wEvent_)
 
 {----------------------------------------------------------
     The UI monad
 ----------------------------------------------------------}
 
+-- | Context-dependent layout
+type CxLayout = CxMonoid Layout
+
+instance Title Layout where title = boxed
+
 -- | The UI monad
-type UI = ReaderT Win (WriterT Act (LayoutT IO))
+type UI = ReaderT Win (WriterT CxLayout (WriterT (Source Action) IO))
 
--- | Sources of values (data-driven)
-type Source = DataDriven IO
+-- | Source-valued UI
+type UIS a = UI (Source a)
 
--- | IO-based action
-type Act = Action IO -- == IO ()
+-- | Event-valued UI
+type UIE a = UI (Event  a)
 
--- | IO-based sink
-type Snk a = Sink IO a
+-- Standard monad-as-applicative instance
+instance Applicative UI where { pure = return ; (<*>) = ap }
 
--- | Run a 'UI' with window title \"Monadic Phooey GUI\".
-runUI :: UI (Source ()) -> IO ()
-runUI = runNamedUI "Monadic Phooey GUI"
+-- Standard AF-as-monoid instance
+instance Monoid o => Monoid (UI o) where
+  mempty  = pure   mempty
+  mappend = liftA2 mappend
 
--- | Run a 'UI' with given window title.
-runNamedUI :: String -> UI (Source ()) -> IO ()
-runNamedUI name = runL name . ((liftM runDD' . runWriterT) .) . runReaderT
- where
-   runDD' :: (Source (), Act) -> Act
-   runDD' (src, delayed) = runDD src >> delayed   -- or delayed first?
+-- | Convenient variation of 'UI'
+type UI' a = Win -> IO ((a, CxLayout), Source Action)
 
--- | Run a 'UI' with window title \"Monadic Phooey GUI\" -- alternative version
-runUI' :: UI (Source Act) -> Act
-runUI' = runNamedUI' "Monadic Phooey GUI"
+-- Convenient bijection
+biReaderT :: (r -> m a) :<->: ReaderT r m a 
+biReaderT = Bi ReaderT runReaderT
 
--- | Run a 'UI' with given window title -- alternative version.  Works
--- with \"alternative\"-style outputs.
-runNamedUI' :: String -> UI (Source Act) -> Act
-runNamedUI' name = runNamedUI name . liftM joinDD
+biWriterT :: m (a, w) :<->: WriterT w m a 
+biWriterT = Bi WriterT runWriterT
 
+-- | Bijection for convenient manipulation.  
+biUI :: UI' a :<->: UI a
+biUI = bimap (biWriterT >>> biWriterT) >>> biReaderT
 
-{----------------------------------------------------------
-    Tools for high-level widgets
-----------------------------------------------------------}
+-- In biUI, the bimap is for the (->) Win, and each biWriterT un/wraps a WriterT.
 
--- | Input widget type (with initial value)
-type IWidget  a =        a -> UI (Source a)
--- | Output widget type
-type OWidget  a = Source a -> UI (Source ())
--- | Alternative output widget type
-type OWidget' a = UI (Snk a)
+-- Separate biUI into separately typed pieces.
 
--- | Combine input & output widget types
-type IOWidget a = (IWidget a, OWidget a, OWidget' a)
+-- TODO: look for alternatives.
 
--- | Type of widget-making functions
-type MkWidget widget a b =
-  Unop Layout -> (Win -> [Prop widget] -> IO widget) -> Attr widget a -> b
+-- | Make from representation
+toUI :: UI' a -> UI a
+toUI = biTo biUI
 
--- iwidgetSource :: Commanding widget =>
---                  (Win -> [Prop widget] -> IO widget)  -- ^ widget maker
---               -> Attr widget a                        -- ^ widget attribute
---               -> a                                    -- ^ initial value
---               -> Win                                  -- ^ parent
---               -> IO (widget, Source a)
--- iwidgetSource mkWid attr initial win =
---   do  wid  <- mkWid win [ attr := initial ]
---       news <- commandNews wid
---       return (wid, dd news (get wid attr))
+-- | Extract representation
+fromUI :: UI b -> UI' b
+fromUI = biFrom biUI
 
--- | Make a (data-driven) value source for a given widget and attribute.
-commandSource :: Commanding widget =>
-                 widget         -- ^ widget
-              -> Attr widget a  -- ^ attribute
-              -> IO (Source a)
-commandSource wid attr = fmap (dd (get wid attr)) (commandNews wid)
+-- | Apply a unary function inside the 'UI' representation.
+inUI :: (UI' a -> UI' b) -> (UI a -> UI b)
+inUI = (toUI .) . (. fromUI)
 
--- commandSource wid attr =
---   do  news <- commandNews wid
---       return (dd news (get wid attr))
+-- | Run a 'UI' with window title \"Monadic Phooey GUI\".
+runUI :: UI () -> IO ()
+runUI = runNamedUI "Monadic Phooey GUI"
 
+-- | Run a 'UI' with given window title.
+runNamedUI :: String -> UI () -> IO ()
+runNamedUI name ui = start $
+  do  f                <- frame [ visible := False, text := name ]
+      win              <- panel f []
+      (((),cxl),acts)  <- fromUI ui win
+      set win  [ layout := unCxMonoid cxl (empty',above) ]
+      set f    [ layout := hwidget win, visible := True ]
+      runDDJoin acts
 
--- | Make a high-level input widget
-iwidget :: (Commanding widget, Widget widget) => MkWidget widget a (IWidget a)
+-- | Move an action source into position to be executed
+act :: UI (Source Action) -> UI ()
+act = inUI $ (fmap.fmap) doit
+ where
+   doit ((io, l), acts) = (((),l), acts `mappend` io)
 
--- iwidget layf mkWid attr initial = mkWidget layf $ \ win ->
---   do (wid, src) <- iwidgetSource mkWid attr initial win
---      return (wid, (src,mempty))
 
--- iwidget layf mkWid attr initial =
---   mkWidget layf (fmap tag . iwidgetSource mkWid attr initial)
---  where
---    tag (wid, src) = (wid, (src,mempty))
 
---  mkWidget layf (second (flip (,) mempty) (iwidgetSource mkWid attr initial))
+{----------------------------------------------------------
+    Tools for high-level widgets
+----------------------------------------------------------}
 
-iwidget layf mkWid attr initial = mkWidget layf $ \ win ->
-  do  wid  <- mkWid win [ attr := initial ]
-      src  <- commandSource wid attr
-      return (wid, (src,mempty))
+-- | Input widget type (with initial value)
+type IWidget  a =     a -> UI (Source a)
+-- | Output widget type
+type OWidget  a = Source a -> UI ()
+-- | Alternative output widget type
+type OWidget' a = UI (Sink a)
 
--- iwidget layf mkWid attr initial = mkWidget layf $ \ win ->
---   do  wid  <- mkWid win [ attr := initial ]
---       news <- commandNews wid
---       return (wid, (dd news (get wid attr), mempty))
+-- | Combine input & output widget types
+type IOWidget a = (IWidget a, OWidget a, OWidget' a)
 
-type IWidgetDyn a b = Source a -> IWidget b
+-- | Utility type for making widgets
+type MkWidget ctl a b =
+  Unop Layout -> (Win -> [Prop ctl] -> IO ctl) -> Attr ctl a -> b
 
-type MkIWidgetDyn widget a b =
-      Unop Layout
-   -> (Win -> [Prop widget] -> IO (widget, Snk a))
-   -> Attr widget b
-   -> IWidgetDyn a b
+widgetL :: Widget w => Unop Layout -> w -> CxLayout
+widgetL filler ctl = CxMonoid (const (filler (widget ctl)))
 
--- | Slider widget with static initial value and dynamic bounds (min,max)
-iwidgetDyn :: (Commanding widget, Widget widget) => MkIWidgetDyn widget a b
+-- | Make an input widget.  See alos 'iwidget\''.
+iwidget :: (Commanding ctl, Widget ctl) => MkWidget ctl a (IWidget a)
+iwidget = iwidget' command
 
-iwidgetDyn layf mkWid attr srcA initial = mkWidget layf $ \ win ->
-  do  (wid,snkA) <- mkWid win [ attr := initial ]
-      src <- commandSource wid attr
-      return  ( wid
-              , ( src
-                , runDD (mapCur (>>= snkA) srcA) ) )
+-- | Make an input widget with a given update event.  If the update is
+-- 'commanding' you can use 'iwidget'.
+iwidget' :: Widget ctl => WX.Event ctl (IO ()) -> MkWidget ctl a (IWidget a)
+iwidget' ev filler mkWid attr initial = toUI $ \ win ->
+  do  ctl  <- mkWid win [ attr := initial ]
+      src  <- attrSource ev attr ctl
+      -- In the case of 'choices', the creation-time attribute set is not
+      -- enough, so set it here again.
+      set ctl [ attr := initial ]
+      --   and invoke any event handlers
+      join $ getAttr (on ev) ctl
+      return ((src, widgetL filler ctl), mempty)
 
--- iwidgetDyn layf mkWid attr src initial = mkWidget layf $ \ win ->
---   do  (wid,snkA) <- mkWid win [ attr := initial ]
---       news       <- commandNews wid
---       return  ( wid
---               , ( dd news (get wid attr)
---                 , runDD (mapGet (>>= snkA) src) ) )
+-- TODO: look in WinEvents for helpers.
 
--- OWidget is convenient for a monad interface.  For building an
--- applicative functor, we'll want the the alternative OWidget' style.
+-- | Tweaks output style
+outFun :: OWidget' a -> OWidget a
+outFun ui src =
+  -- Apply sinks to values & move to actions
+  act $ fmap (<$> src) ui
 
 -- | Make a high-level output widget
 owidget :: Widget widget => MkWidget widget a (OWidget a)
-owidget layf mkWid attr src =
-  liftM (joinDD . (<$> src)) (owidget' layf mkWid attr)
+owidget filler mkWid attr = outFun (owidget' filler mkWid attr)
 
--- | Make a high-level output widget
-owidget' :: Widget widget => MkWidget widget a (OWidget' a)
-owidget' layf mkWid attr = mkWidget layf $ \ win ->
-  do  wid <- mkWid win [ ]
-      return (wid, (\ a -> set wid [ attr := a ], mempty))
+-- | Output widget, alternative style
+owidget' :: Widget ctl => MkWidget ctl a (OWidget' a)
+owidget' filler mkWid attr = toUI $ \ win ->
+  do  ctl <- mkWid win [ ]
+      return ((setAttr attr ctl, widgetL filler ctl), mempty)
 
 -- | Convenience function combining 'iwidget', 'owidget', and 'owidget\''
 iowidget :: (Commanding widget, Widget widget) => MkWidget widget a (IOWidget a)
-iowidget layf mkWid attr =
-  (iwidget layf mkWid attr, owidget layf mkWid attr, owidget' layf mkWid attr)
+iowidget filler mkWid attr =
+  (iwidget filler mkWid attr, owidget filler mkWid attr, owidget' filler mkWid attr)
 
 
 {----------------------------------------------------------
@@ -211,7 +225,7 @@
 -- | Alternative string output widget
 stringDisplay' :: OWidget' String
 
-(stringEntry,stringDisplay,stringDisplay') = iowidget hfill WX.textEntry text
+(stringEntry,stringDisplay,stringDisplay') = iowidget hfill textEntry text
 
 -- | Showable output widget
 showDisplay :: Show a => OWidget a
@@ -245,10 +259,62 @@
    thd3 (_,_,c) = c
 
 
--- | Slider widget with static initial value and dynamic bounds (min,max)
-isliderDyn :: Source (Int,Int) -> IWidget Int
-isliderDyn = iwidgetDyn hfill (flip hsliderDyn True) selection
 
+-- | Fractional slider, alternative interface
+fslider :: forall a. RealFrac a => (a,a) -> IWidget a
+fslider (lo,hi) initial = toUI $ \ win ->
+  do pan  <- panel win [ ]
+     pbg  <- get pan bgcolor
+     cval <- textEntry pan [ clientSize :~ \ (Size _ h) -> Size 40 h
+                           , bgcolor := pbg
+                           ]
+     slid <- hslider pan False (toI lo) (toI hi)
+             [ selection := toI initial
+             , size :~ \ (Size _ h) -> (Size 80 h)]
+     set pan [ layout := row 5 [ widget cval, label (show lo)
+                               , fill $ widget slid, label (show hi) ] ]
+     isrc <- attrSource command selection slid
+     let fsrc = fmap toF isrc
+     -- update the value display when it changes
+     runDDJoin $ (setAttr text cval . show) <$> fsrc
+     return ((fsrc, widgetL hfill pan), mempty)
+ where
+   toI x = round ((x - lo) * scale)
+   toF i = fromIntegral i / scale + lo
+   scale = steps / (hi - lo)
+   steps = 3000 :: a
+
+-- TODO: some factoring between fslider and fsliderDisplay'.
+
+-- | Fractional slider
+fsliderDisplay :: forall a. RealFrac a => (a,a) -> OWidget a
+fsliderDisplay = outFun . fsliderDisplay'
+
+-- | Fractional slider, alternative interface
+fsliderDisplay' :: forall a. RealFrac a => (a,a) -> OWidget' a
+fsliderDisplay' (lo,hi) = toUI $ \ win ->
+  do pan  <- panel win [ ]
+     pbg  <- get pan bgcolor
+     cval <- textEntry pan [ clientSize :~ \ (Size _ h) -> Size 40 h
+                           , bgcolor := pbg
+                           , on keyboard := mempty -- ignore input
+                           ]
+     slid <- hslider pan False (toI lo) (toI hi) [ enabled := False ]
+     set pan [ layout := row 5 [ widget cval, label (show lo)
+                               , fill $ widget slid, label (show hi) ] ]
+     let update x = do set slid [ selection := toI x ]
+                       set cval [ text := show x ]
+     return ((update, widgetL hfill pan), mempty)
+ where
+   toI x = round ((x - lo) * scale)
+   scale = steps / (hi - lo)
+   steps = 3000 :: a
+
+-- -- | Alternative output widget type
+-- type OWidget' a = UI (Sink a)
+
+
+
 -- | Boolean input widget
 checkBoxEntry :: IWidget Bool
 
@@ -260,64 +326,91 @@
 
 (checkBoxEntry,checkBoxDisplay,checkBoxDisplay') = iowidget hfill WX.checkBox checked
 
--- | Wrap a title around a 'UI'
-title :: String -> Unop (UI a)
-title str = mapLayout (boxed str)
+-- | Input from a \"menu\" of string choices.
+choices :: [String] -> IWidget String
+choices strings dflt = iwidget' select hfill combo text' dflt
+ where
+   combo w props =
+     do ctl <- comboBox w props
+        mapM_ (appendText ctl) strings
+        -- I don't know why the following line is required
+        -- set ctl [ text' := dflt ]
+        return ctl
+   text' = newAttr "choiceSelection"
+             (\ w -> fmap (strings !!) (getAttr selection w))
+             (\ w str -> setAttr selection w (fromJust (elemIndex str strings)))
 
 
-{----------------------------------------------------------
-    Layout
-----------------------------------------------------------}
+-- | Input from a timer and a means of polling.  Interval is in seconds.
+-- If 'poll' is expensive, then apply 'cache' to the resulting UI.
+timedPoll :: Double -> IO a -> UI (Source a)
+timedPoll secs poll = toUI $ \ w ->
+  do tim <- timer w [ interval := round (1000 * secs) ]
+     return ((O (wEvent_ command tim, poll), mempty), mempty)
 
--- | Lay out from top to bottom
-fromTop :: Unop (UI a)
-fromTop = onLayoutT fromTopL
+-- | Cache a source, presumably with an expensive polling action
+cache :: UI (Source a) -> UI (Source a)
+cache = inUI cache'
+ where
+   cache' ui' w = do ((src,cxl),acts) <- ui' w
+                     cached <- cacheS src
+                     return ((cached,cxl),acts)
 
--- | Lay out from bottom to top
-fromBottom :: Unop (UI a)
-fromBottom = onLayoutT fromBottomL
+-- type UI' a = Win -> IO ((a, CxLayout), Source Action)
 
--- | Lay out from left to right
-fromLeft :: Unop (UI a)
-fromLeft = onLayoutT fromLeftL
 
--- | Lay out from right to left
-fromRight :: Unop (UI a)
-fromRight = onLayoutT fromRightL
 
--- | Reverse layout
-flipLayout :: Unop (UI a)
-flipLayout = onLayoutT flipL
+-- Wrap a title around a 'UI'
+instance Title_f UI where title_f str = onCxLayout' (boxed str .)
 
 
+-- | Simple button with value & label.  Use 'button\'' for custom properties.
+button :: a -> String -> UI (Event a)
+button a txt = button' a [ text := txt ]
+
+-- | Button with value & properties.  If you just want a label, use 'button'.
+button' :: a -> [Prop (Button ())] -> UI (Event a)
+button' a props = toUI $ \ win ->
+  do ctl <- WX.button win props
+     return ( (replace a (wEvent_ command ctl), widgetL fill ctl)
+            , mempty)
+
+-- | Minimal size button with value & label
+smallButton :: a -> String -> UI (Event a)
+smallButton a txt = toUI $ \ win ->
+  do ctl <- WX.smallButton win [ text := txt ]
+     return ( (replace a (wEvent_ command ctl), widgetL fill ctl)
+            , mempty)
+
+-- TODO: rewrite button' in >=> style.  See how it looks.
+
+
+
 {----------------------------------------------------------
-    Misc tools
+    Layout
 ----------------------------------------------------------}
 
--- | Make a widget
-mkWidget :: forall a widget. Widget widget
-         => Unop Layout   -- ^ filler: id, hfill, vfill, or fill
-         -> (Win -> IO (widget, (a, Act)))
-         -> UI a
-mkWidget layf f = ReaderT (WriterT . mkTag . panelWrap layf f')
- where
-   f' :: Win -> IO (Maybe Layout, (a, Act))
-   f' w = liftM (first (Just . layf . widget)) (f w)
+fromTop, fromBottom, fromLeft, fromRight, flipLayout :: Unop (UI a)
+fromLeft  = withCxMonoid (empty',leftOf)
+fromTop  = withCxMonoid (empty',above)
+flipLayout   = compCxMonoid (second flip)
 
+fromBottom = flipLayout . fromTop
+fromRight = flipLayout . fromLeft
 
--- | Tweak the 'LayoutT'
-onLayoutT :: LayoutTOp IO -> Unop (UI a)
-onLayoutT f = mapReaderT' (mapWriterT' f)
+withCxMonoid :: MonoidDict Layout -> Unop (UI a)
+withCxMonoid dict = compCxMonoid (const dict)
 
--- | Tweak the layout
-mapLayout :: Unop Layout -> Unop (UI a)
-mapLayout f = onLayoutT (mapTag f)
+compCxMonoid :: Unop (MonoidDict Layout) -> Unop (UI a)
+compCxMonoid f = onCxLayout' (. f)
 
+onCxLayout :: Unop CxLayout -> Unop (UI a)
+onCxLayout f = inUI $ (fmap.fmap.first.second) f
 
--- Same defs as 'mapReaderT', 'mapWriterT', but different types
+onCxLayout' :: Unop (MonoidDict Layout -> Layout) -> Unop (UI a)
+onCxLayout' f' = onCxLayout (CxMonoid . f' . unCxMonoid)
 
-mapWriterT' :: UUnop m -> UUnop (WriterT w m)
-mapWriterT' f m = WriterT $ f (runWriterT m)
 
-mapReaderT' :: UUnop m -> UUnop (ReaderT w m)
-mapReaderT' f m = ReaderT $ f . runReaderT m
+{----------------------------------------------------------
+    Misc
+----------------------------------------------------------}
diff --git a/src/Graphics/UI/Phooey/TagT.hs b/src/Graphics/UI/Phooey/TagT.hs
deleted file mode 100644
--- a/src/Graphics/UI/Phooey/TagT.hs
+++ /dev/null
@@ -1,121 +0,0 @@
-{-# OPTIONS -fglasgow-exts #-}
-
-----------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.Phooey.TagT
--- Copyright   :  (c) Conal Elliott 2006
--- License     :  LGPL
--- 
--- Maintainer  :  conal@conal.net
--- Stability   :  provisional
--- Portability :  portable
--- 
--- A /tagging/ monad transformer
-----------------------------------------------------------------------
-
-module Graphics.UI.Phooey.TagT
-  (
-  -- * Convenient function synonyms
-    Unop, UUnop, Binop
-  -- * The /tagging/ monad transformer (or tagged-value maker)
-  , TagT(..), runTag
-  -- * Transforming tagged-value makers
-  , TagTOp, mapTag, mkTag
-  -- * Tag-combiner tweakers
-  , updateTagComb, setTagComb, flipTagComb
-  ) where
-
-import Control.Monad.Reader
-import Control.Monad.Trans
-import Control.Arrow (first)
-
-{----------------------------------------------------------
-    Convenient function synonyms
-----------------------------------------------------------}
-
-type Unop   a = a -> a
-type Binop  a = a -> a -> a
-
-type UUnop f = forall a. Unop (f a)
-
-
-{----------------------------------------------------------
-    The /tagging/ monad transformer / tagged-value maker.
-    Tags may be present or absent and are combined according to
-    a contextual 'Binop'.
-----------------------------------------------------------}
-
-newtype TagT tag m a =
-  T { unT :: ReaderT (Binop tag) m (Maybe tag,a) }
-
--- | Run a 'TagT'
-runTag :: Binop tag       -- ^ the tag combiner
-       -> TagT tag m a
-       -> m (Maybe tag,a)
-runTag op (T r) = runReaderT r op
-
-instance Monad m => Monad (TagT tag m) where
-  return a   = lift (return a)
-  wta >>= f  = T (do  ~(ta,a)  <- unT wta
-                      ~(tb,b)  <- unT (f a)
-                      op      <- ask
-                      return (mb op ta tb, b))
-    where
-      mb op (Just a)  (Just b)  = Just (a `op` b)
-      mb _  mba       mbb       = mba `mplus` mbb
-
-instance MonadFix m => MonadFix (TagT tag m) where
-  mfix f = T (mfix (\ ~(_,a) ->  unT (f a)))
-
-instance Monad m => Functor (TagT tag m) where
-  fmap f ui = ui >>= return . f
-
-
-{----------------------------------------------------------
-    Transforming tagged-value makers
-----------------------------------------------------------}
-
--- | Transforming tagged-value makers into others
-type TagTOp tag m = forall a. Unop (TagT tag m a)
-
--- | Tag changer
-mapTag :: Monad m => Unop tag -> TagTOp tag m
-mapTag f (T reader) = T (liftM (first (fmap f)) reader)
-
--- | Make a tagged-value maker from a tag and a value
-mkTag :: Monad m => m (Maybe tag,a) -> TagT tag m a
-mkTag m = T (lift m)
-
-{----------------------------------------------------------
-    Tag-combiner tweakers
-----------------------------------------------------------}
-
--- | Temporarily /update/ the tag combiner
-updateTagComb  ::  Monad m =>
-                 Unop (Binop tag)
-             ->  Unop (TagT tag m a)
-updateTagComb h (T r) = T (local h r)
-
--- Augment the context for the duration of a computation.
--- Maybe rename and put back in MonadLib
--- updateR :: RunReaderM m i => (i->i) -> m a -> m a
--- updateR f m = do r <- ask
---                  local (f r) m
-
-
--- | Temporarily /replace/ the tag combiner
-setTagComb  ::  Monad m => Binop tag ->  Unop (TagT tag m a)
-setTagComb op = updateTagComb (const op)
-
--- | Temporarily /reverse/ the tag combiner
-flipTagComb ::  Monad m => Unop (TagT tag m a)
-flipTagComb = updateTagComb flip
-
-instance MonadTrans (TagT tag) where
-  lift m = T (lift (do  a <- m
-                        return (Nothing,a)))
-
--- instance BaseM m b => BaseM (TagT tag m) b where
---   inBase m = lift (inBase m)
-
--- Add more transformer instances 
diff --git a/src/Graphics/UI/Phooey/WinEvents.hs b/src/Graphics/UI/Phooey/WinEvents.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/UI/Phooey/WinEvents.hs
@@ -0,0 +1,444 @@
+{-# LANGUAGE Rank2Types  #-}
+-- For ghc 6.6 compatibility
+-- {-# OPTIONS -fglasgow-exts -fno-warn-orphans #-}
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      :  Graphics.UI.Phooey.WinEvents
+-- Copyright   :  (c) Conal Elliott 2007
+-- License     :  LGPL
+-- 
+-- Maintainer  :  conal@conal.net
+-- Stability   :  experimental
+-- Portability :  ???
+-- 
+-- Wrap window toolkit as 'Event's & 'Source's
+-- TODO: Move out of phooey
+----------------------------------------------------------------------
+
+module Graphics.UI.Phooey.WinEvents
+  (
+  -- * 'Event's from wxHaskell-style events
+    wEvent, wEvent_, attrSource
+  -- * Attributes
+  ,  InAttr, OutAttr, inAttr, outAttr
+  -- * Window-based computations
+  , WiU, WiE, WiS
+  , WioU, Wio, WioE, WioS
+  -- ** Events
+  , mouseE, enter, leave, inside
+  , motion, motion', motionDiff, motionDiff'
+  , leftDown, leftUp, rightDown, rightUp
+  -- ** Sources
+  , size, leftIsDown, mouse, mbMouse, leftDragAccum
+  -- * Image display
+  , image, arrayImage
+  -- * Making widgets with sources & sinks
+  , MkCtl, mkMkCtl, MkIn, MkOut, attrMkIn, attrMkOut
+  -- * Menus
+  , LTree(..), lookupLTree, lookupLTrees
+  , titledItem, menuEvent, menuEvent', allEnabled, menuH, menuH'
+  -- * Misc
+  , mkStatus, getAttr, setAttr, modifyAttr, mapAttr'
+  ) where
+
+
+import Control.Applicative
+import Data.Array
+import Control.Monad (msum)
+import Data.Monoid (mappend)
+import System.IO.Unsafe (unsafePerformIO) -- for pixelArray
+
+-- TypeCompose
+import Control.Compose (Unop)
+import Data.Pair (Pair(..))
+import Data.Title
+
+-- wxHaskell
+import Graphics.UI.WX hiding (image,mouse,enter,leave,motion,size,drag,Event)
+import qualified Graphics.UI.WX as WX
+import qualified Graphics.UI.WXCore as WXC
+
+-- DataDriven
+import Data.Event
+import Data.Source
+-- import Data.UndoEvent -- in transition
+
+import Graphics.UI.Phooey.Imperative
+
+{----------------------------------------------------------
+    'Event's from wxHaskell-style events
+----------------------------------------------------------}
+
+-- | Make an 'Event' out of a wxHaskell-style event, which must be
+-- /readable/ and writeable.
+wEvent :: WX.Event ctl (Sink a) -> ctl -> Event a
+wEvent wxe ctl = mkEvent $ modifyAttr (on wxe) ctl
+
+-- modifyAttr :: Attr w a -> w -> Sink (a -> a)
+
+-- | Like 'wEvent' but for wxHaskell-style events that don't take data.
+wEvent_ :: WX.Event ctl (IO ()) -> ctl -> Event ()
+wEvent_ wxe ctl = -- error "wEvent_ undefined"
+                  mkEvent $ modifyAttr (on wxe) ctl . h'
+ where
+    -- h :: Unop Action -> Unop (Sink ())
+    -- h f snk = const (f (snk ()))
+    h' :: Unop (Sink ()) -> Unop Action
+    h' g act = g (const act) ()
+
+-- | Wrap an attribute & control as a value source.  Specializes to
+-- 'inAttr' when @change == command@.
+attrSource :: WX.Event ctl (IO ()) -> Attr ctl a -> ctl -> IO (Source a)
+attrSource change attr ctl =
+  do let ev = wEvent_ change ctl
+     x  <- get ctl attr                 -- initial value
+     x `stepper` (ev `snapget_` get ctl attr)
+
+{----------------------------------------------------------
+    Attributes
+----------------------------------------------------------}
+
+-- | Wrapped input attribute
+type InAttr  ctl a = ctl -> IO (Source a)
+-- | Wrapped input attribute
+type OutAttr ctl a = ctl -> IO (Source (Sink a))
+
+-- | Convert a wxHaskell-style input attribute
+inAttr :: Commanding ctl => Attr ctl a -> InAttr ctl a
+inAttr = attrSource command
+
+-- | Convert a wxHaskell-style input attribute
+outAttr :: Attr ctl a -> OutAttr ctl a
+outAttr attr ctl = (pure.pure) $ setAttr attr ctl
+
+
+{----------------------------------------------------------
+    Window-based computations
+----------------------------------------------------------}
+
+-- | Window-based computations, universal over Reactive types
+type WiU a = forall ctl. Reactive ctl => ctl -> a
+-- | Control-based events
+type WiE a = WiU (Event  a)
+-- | Control-Based sources
+type WiS a = WiU (Source a)
+
+-- | Window&IO-based computations, universal over widow types
+type WioU a = forall ctl. Window ctl -> IO a
+-- | Control-based events
+type WioE a = WioU (Event  a)
+-- | Control-Based sources
+type WioS a = WioU (Source a)
+
+{----------------------------------------------------------
+    Events
+----------------------------------------------------------}
+
+debugEvents :: Bool
+debugEvents = False
+
+trace :: String -> Event a -> Event a
+trace str | debugEvents = traceE (const str)
+          | otherwise   = id
+
+-- | Filter mouse events
+mouseE :: String -> (EventMouse -> Maybe a) -> WiE a
+mouseE str f ctl = trace str $ (justE . fmap f) $ wEvent WX.mouse ctl
+
+-- | Mouse enters control
+enter :: WiE ()
+enter = mouseE "enter" enterF
+ where
+   enterF (MouseEnter {}) = Just () ; enterF _ = Nothing
+
+-- | Mouse leaves control
+leave :: WiE ()
+leave = mouseE "leave" leaveF
+ where
+   leaveF (MouseLeave {}) = Just () ; leaveF _ = Nothing
+
+-- | Whether the mouse is in the control
+inside :: WioS Bool
+inside ctl =
+  False `stepper`
+   (replace True (enter ctl) `mappend` replace False (leave ctl))
+
+-- | Mouse motion event.  Includes wxHaskell motion, enter, leave, and
+-- left/right/middle-drag.  Both point and modifiers.  See also 'motion',
+-- which omits modifiers.
+motion' :: WiE (Point,Modifiers)
+motion' = mouseE "motion" motionF
+ where
+   motionF (MouseMotion     p mods) = Just (p,mods)
+   motionF (MouseEnter      p mods) = Just (p,mods)
+   motionF (MouseLeave      p mods) = Just (p,mods)
+   motionF (MouseLeftDrag   p mods) = Just (p,mods)
+   motionF (MouseRightDrag  p mods) = Just (p,mods)
+   motionF (MouseMiddleDrag p mods) = Just (p,mods)
+   motionF _                        = Nothing
+
+-- | Mouse motion event.  Includes wxHaskell motion, enter, leave, and
+-- left/right/middle-drag.  Simplified version of 'motion\'', which also
+-- includes key 'Modifiers'.
+motion :: WiE Point
+motion = (fmap.fmap) fst motion'
+
+
+-- | Mouse motion as difference vectors.  Includes 'Modifiers'.
+motionDiff' :: WioE (Vector,Modifiers)
+motionDiff' ctl = (fmap.fmap) f (withPrevE (motion' ctl))
+ where
+   f ((v1,m1),(v0,_)) = (v1 `vecBetween` v0, m1)
+
+-- | Mouse motion as difference vectors.  Simplified from 'motionDiff\''.
+motionDiff :: WioE Vector
+motionDiff = (fmap.fmap.fmap) fst motionDiff'
+
+-- | Left button down
+leftDown :: WiE Point
+leftDown = mouseE "leftDown" leftDownF
+ where
+   leftDownF (MouseLeftDown wxp _) = Just wxp ; leftDownF _ = Nothing
+
+-- | Left button up
+leftUp :: WiE Point
+leftUp = mouseE "leftUp" leftUpF
+ where
+   leftUpF (MouseLeftUp wxp _) = Just wxp ; leftUpF _ = Nothing
+
+-- | Right button down
+rightDown :: WiE Point
+rightDown = mouseE "rightDown" rightDownF
+ where
+   rightDownF (MouseRightDown wxp _) = Just wxp ; rightDownF _ = Nothing
+
+-- | Right button up
+rightUp :: WiE Point
+rightUp = mouseE "rightUp" rightUpF
+ where
+   rightUpF (MouseRightUp wxp _) = Just wxp ; rightUpF _ = Nothing
+
+
+{----------------------------------------------------------
+    Sources
+----------------------------------------------------------}
+
+size :: (Reactive ctl, Sized ctl) => ctl -> IO (Source Size)
+size = attrSource resize WX.size
+
+-- I don't know what I'll really want for mouse position behavior.  For
+-- now, a maybe-valued source, being Nothing when the mouse is outside of
+-- the window.
+
+-- | Whether the left button is down
+leftIsDown :: WioS Bool
+leftIsDown ctl = flipFlop (leftDown ctl) (leftUp ctl)
+
+-- | Mouse location source.  Starts at point zero
+mouse :: WioS Point
+mouse ctl = pointZero `stepper` motion ctl
+
+-- | Mouse location source, when in the control
+mbMouse :: WioS (Maybe Point)
+mbMouse ctl = maybeSource (motion ctl) (leave  ctl)
+
+-- | Accumulation of mouse movements while left-dragging
+leftDragAccum :: Vector -> WioS Vector
+leftDragAccum v0 ctl =
+  do diff   <- motionDiff ctl
+     isDown <- leftIsDown ctl
+     accumS v0 (fmap vecAdd (diff `whenE` isDown))
+
+{----------------------------------------------------------
+    Image display
+----------------------------------------------------------}
+
+-- | Write-only image attribute.
+image :: Attr (Window w) (WXC.Image ())
+image = writeAttr "image"
+          (\ ctl img -> do set ctl [on paint := paintImage img]
+                           repaint ctl )
+ where
+   paintImage :: WXC.Image () -> DC () -> Rect -> IO ()
+   paintImage img = \ dc _ ->
+     drawImage dc img (WX.Point 0 0) []
+
+
+-- Is there any reason for imageCreateFromPixelArray to be in IO?
+arrayImage :: Array WX.Point Color -> WXC.Image ()
+arrayImage = unsafePerformIO . imageCreateFromPixelArray
+
+
+{----------------------------------------------------------
+    Making widgets with sources & sinks
+----------------------------------------------------------}
+
+-- | Control\/widget maker
+type MkCtl ctl a = Win -> [Prop ctl] -> IO (ctl, Attr ctl a)
+
+-- | More conventional but less general interface to 'MkCtl'
+mkMkCtl :: Attr ctl a -> (Win -> [Prop ctl] -> IO ctl) -> MkCtl ctl a
+mkMkCtl attr = (fmap.fmap.fmap) (flip (,) attr)
+
+-- | Make an input control
+type MkIn ctl a = a -> Win -> IO (ctl, (Source a, Source (Sink a)))
+
+-- TODO: Consider 
+-- 
+--   type MkIn a = a -> Win -> IO (Layout, Source a)
+-- 
+-- and similarly for 'MkOut'.  If so, move WinIO & WinIO' from Eros.
+-- 
+-- Somehow accommodate the use of selectE & setToolTip in Eros.
+
+-- | Attribute-based input control
+attrMkIn:: Commanding ctl =>
+           MkCtl ctl a -> [Prop ctl] -> MkIn ctl a
+attrMkIn mk props = \ a win ->
+  do (ctl,attr) <- mk win props
+     set ctl [ attr := a ]
+     src        <- inAttr attr ctl
+     return (ctl, (src, pure $ setAttr attr ctl))
+
+
+-- | Make an output control
+type MkOut ctl a = Win -> IO (ctl, Source (Sink a))
+
+-- | Attribute-based output control
+attrMkOut :: MkCtl ctl a -> [Prop ctl] -> MkOut ctl a
+attrMkOut mk props = \ win ->
+  do (ctl,attr) <- mk win props
+     snks       <- outAttr attr ctl
+     return (ctl, snks)
+
+
+{----------------------------------------------------------
+    Menus
+----------------------------------------------------------}
+
+-- Non-hierarchical menus.  Phase out these ones.
+
+-- | Make an event that interfaces as a menu.  The bool sources say when
+-- each menu item is enabled
+menuEvent :: Window w -> [Prop (Menu ())] -> [(String, Source Bool, a)] -> IO (Menu (), Event a)
+menuEvent w props choices =
+  do m <- menuPane props
+     e <- menuEvent' w m choices
+     return (m,e)
+
+-- | Like 'menuEvent', but you supply your own menu to fill.  
+menuEvent' :: Window w -> Menu () -> [(String, Source Bool, a)] -> IO (Event a)
+menuEvent' w m choices =
+  do (sink,e) <- refEvent
+     sequence_ [ do it <- menuItem m [text := name]
+                    runDDJoin $  setAttr enabled it <$> ables
+                    set w [ on (menu it) := sink a ]
+               | (name,ables,a) <- choices ]
+     return e
+
+-- | Convenience for use with 'menuEvent'.  Fill in @pure True@ for
+-- whether-enabled sources.
+allEnabled :: [(String,a)] -> [(String,Source Bool,a)]
+allEnabled = fmap (\ (n,tw) -> (n,pure True,tw))
+
+-- | Trees with labels at each internal node and leaf, plus data at the leaves.
+data LTree k a = TItem k a
+               | TChildren k [LTree k a]
+
+-- | Titled LTree item.  Use name for 'title' and 'TItem'
+titledItem :: Title a => String -> a -> LTree String a
+titledItem name utv = TItem name (title name utv)
+
+instance Functor (LTree k) where
+  fmap f (TItem k a)      = TItem k (f a)
+  fmap f (TChildren k ts) = TChildren k (map (fmap f) ts)
+
+
+-- | Hierarchical menu from 
+menuH :: Window w -> [Prop (Menu ())] -> [LTree String a] -> IO (Menu (), Event a)
+menuH w props trees =
+  do top <- menuPane props
+     e <- menuH' w top trees
+     return (top,e)
+
+menuH' :: Window w -> Menu () -> [LTree String a] -> IO (Event a)
+menuH' w top trees =
+  do (sink,e) <- refEvent
+     let -- populate :: Menu () -> LTree String a -> IO ()
+         populate m (TItem     k  a) = do it <- menuItem m [text := k]
+                                          set w [ on (menu it) := sink a ]
+         populate m (TChildren k ts) = do sub <- menuPane [text := k]
+                                          menuSub m sub []
+                                          populates sub ts
+         populates m                 = mapM_ (populate m)
+     populates top trees
+     return e
+
+-- | Find the first item with the given label
+lookupLTree :: Eq key => key -> LTree key a -> Maybe a
+lookupLTree k (TItem     k'  a) | k' == k  = Just a
+                                | otherwise = Nothing
+lookupLTree k (TChildren _ ts) = lookupLTrees k ts
+
+lookupLTrees :: Eq key => key -> [LTree key a] -> Maybe a
+lookupLTrees k = msum . map (lookupLTree k)
+
+{----------------------------------------------------------
+    Misc GUI
+----------------------------------------------------------}
+
+-- Make a status field and return way to write to it
+mkStatus :: Frame w -> [Prop StatusField] -> IO (Sink String)
+mkStatus w props = do status <- statusField props
+                      set w [ statusbar := [status] ]
+                      return $ \ str -> set status [ text := str ]
+
+-- |  Get attribute.  Just a flipped 'get'.  Handy for partial application.
+getAttr :: Attr w a -> w -> IO a
+getAttr = flip get
+
+-- | Set a single attribute.  Handy for partial application.
+setAttr :: Attr w a -> w -> Sink a
+setAttr attr ctl x = set ctl [ attr := x ]
+
+-- | Modify a single attribute.  Handy for partial application.
+modifyAttr :: Attr w a -> w -> Sink (a -> a)
+modifyAttr attr ctl f = do -- putStrLn $ "modifyAttr " ++ attrName attr
+                           set ctl [ attr :~ f ]
+
+
+-- From Graphics.UI.WX.Attributes source:
+-- 
+-- (@mapAttr get set attr@) maps an attribute of @Attr w a@ to
+-- @Attr w b@ where (@get :: a -> b@) is used when the attribute is
+-- requested and (@set :: a -> b -> a@) is applied to current
+-- value when the attribute is set.
+
+-- | Variant of 'mapAttr', in which the functions have access to control
+mapAttr' :: String -> (w -> a -> IO b) -> (w -> a -> b -> IO a)
+         -> Attr w a -> Attr w b
+mapAttr' name getf setf attr =
+  makeAttr name getter' setter' updater'
+  where
+    getter'  w   = do a <- get w attr; getf w a
+    setter'  w b = do a <- get w attr; a' <- setf w a b; set w [attr := a']
+    updater' w f = do a <- getter' w; setter' w (f a); getter' w
+
+-- -- unused
+-- cond :: Applicative f => f Bool -> f a -> f a -> f a
+-- cond = liftA3 (\ a b c -> if a then b else c)
+
+
+---- Experiment: attribute pairing.  Orphan instance
+
+instance Pair (Attr ctl) where
+  a `pair` b = newAttr ("("++attrName a++","++attrName b++")")
+                 (liftA2 pair (getAttr a) (getAttr b))
+                 (\ w (u,v) -> setAttr a w u >> setAttr b w v)
+
+-- newAttr :: String -> (w -> IO a) -> (w -> a -> IO ()) -> Attr w a
+
+-- what about Lambda?