adddir ./Examples
addfile ./Examples/Bounce.hs
hunk ./Examples/Bounce.hs 1
+module Main where
+
+import Graphics.UI.Fui
+
+-------------------------------------------------------------------------
+
+sizeX, sizeY, maxY, radius :: Int
+sizeX  = 300
+sizeY  = 400
+maxY   = 400 - radius
+radius = 20
+
+-------------------------------------------------------------------------
+
+main :: IO ()
+main = run bouncing
+
+-------------------------------------------------------------------------
+
+bouncing :: GUI
+bouncing =
+  channel $ \drive ->
+  channel $ \new ->
+    window [ text <+ val "Bouncing" ] (
+      canvas [ size (sizeX,sizeY)
+             , drawing    <+ animation (source drive)
+             , mouseClick +> mapSink click (sink drive)
+             ]
+    .^^
+    ( button [ text     <+ val "Clear"
+             , activate +> mapSink (const clear) (sink drive)
+             ]
+    .<<
+      button [ text     <+ val "New"
+             , activate +> sink new
+             ]
+    )
+    .^^
+      timer 20 [ activate +> mapSink (const tick) (sink drive) ]
+  )
+  .^^
+  newWindows (source new)
+
+newWindows :: Stream () -> GUI
+newWindows ticks = dynamic (get ticks $ \() ticks' -> put (bouncing .^^ newWindows ticks') nil)
+
+-------------------------------------------------------------------------
+
+type Ball = (Point,Int)
+type Anim = [Ball] -> [Ball]
+
+animation :: Stream Anim -> Stream Drawing
+animation = fmap draw . fold ($) start
+
+start :: [Ball]
+start = []
+
+click :: Point -> [Ball] -> [Ball]
+click p bs = bs ++ [(p,0)]
+
+tick :: [Ball] -> [Ball]
+tick bs = [ b' | b <- bs, Just b' <- [step b] ]
+
+clear :: [Ball] -> [Ball]
+clear bs = []
+
+draw :: [Ball] -> Drawing
+draw bs = drawings $ concat
+  [ [ Context (fgColor red) (circle True p radius)
+    , circle False p radius
+    ]
+  | (p,v) <- bs
+  ]
+ where
+  red   = rgb 65535 0 0
+  black = rgb 0 0 0
+
+step :: Ball -> Maybe Ball
+step ((x,y),v)
+  | v == 0 && y >= maxY = Nothing
+  | y' > maxY           = Just ((x,y),2-v)
+  | otherwise           = Just ((x,y'),v+1)
+ where
+  y' = y+v
+
+-------------------------------------------------------------------------
+
addfile ./Examples/Draw.hs
hunk ./Examples/Draw.hs 1
+module Main where
+
+import Graphics.UI.Fui
+import Control.Exception
+
+-------------------------------------------------------------------------
+
+sizeX, sizeY :: Int
+sizeX  = 600
+sizeY  = 400
+
+-------------------------------------------------------------------------
+
+main :: IO ()
+main = run drawEdit
+
+-------------------------------------------------------------------------
+
+drawEdit :: GUI
+drawEdit =
+  channel $ \drive ->
+  channel $ \saves ->
+    draw' drive saves .<< draw' drive saves
+
+draw' drive saves =
+  let sts = fold ($) clean (source drive) in
+  window [ text <+ val "Drawing Editor" ] $
+      canvas [ size (sizeX,sizeY)
+             , drawing      <+ draw    +< sts
+             , mouseClick   +> click   >+ sink drive
+             , mouseRelease +> release >+ sink drive
+             , mouse        +> move    >+ sink drive
+             ]
+    .^^
+    ( button [ text     <+ val "Clear"
+             , activate +> const clear >+ sink drive
+             ]
+  .<< button [ text     <+ val "Undo"
+             , activate +> const undo  >+ sink drive
+             ]
+  .<< button [ text     <+ val "Load"
+             , activate +> const load >!+ sink drive
+             ]
+  .<< button [ text     <+ val "Save"
+             , activate +> sink saves
+             ]
+    )
+    .^^
+      ((sts `when` source saves) +>+ save >+ stdio)
+
+-------------------------------------------------------------------------
+
+data State
+  = State
+  { linez   :: [(Point,Point)]
+  , current :: Maybe (Point,Point)
+  }
+ deriving ( Eq, Show, Read )
+
+clean :: State
+clean = State{ linez = [], current = Nothing }
+
+click :: Point -> State -> State
+click p st = st{ current = Just (p,p) }
+
+move :: Point -> State -> State
+move p st = case current st of
+              Nothing     -> st
+              Just (p1,_) -> st{ current = Just (p1,p) }
+
+release :: Point -> State -> State
+release p st = case current st of
+                 Nothing     -> st
+                 Just (p1,_) -> st{ linez   = (p1,p) : linez st
+                                  , current = Nothing
+                                  }
+
+clear :: State -> State
+clear st = clean
+
+undo :: State -> State
+undo st = st{ linez = drop 1 (linez st) }
+
+load :: IO (State -> State)
+load =
+  do ms <- try (readFile "drawing.txt")
+     return (\st -> case ms of
+                      Right s -> read s
+                      _       -> st)
+
+save :: State -> IO ()
+save st =
+  do writeFile "drawing.txt" (show st)
+
+draw :: State -> Drawing
+draw st = drawings $
+  [ Line p1 p2
+  | (p1,p2) <- linez st
+  ] ++
+  [ Context (fgColor red) (Line p1 p2)
+  | Just (p1,p2) <- [current st]
+  ] 
+ where
+  red   = rgb 65535 0 0
+
+-------------------------------------------------------------------------
+
addfile ./Examples/Draw0.hs
hunk ./Examples/Draw0.hs 1
+module Main where
+
+import Graphics.UI.Fui
+
+-------------------------------------------------------------------------
+
+sizeX, sizeY :: Int
+sizeX  = 600
+sizeY  = 400
+
+-------------------------------------------------------------------------
+
+main :: IO ()
+main = run drawEdit
+
+-------------------------------------------------------------------------
+
+drawEdit :: GUI
+drawEdit =
+  channel $ \drive ->
+  let sts = fold ($) clean (source drive) in
+  draw' drive sts .<< draw' drive sts
+
+draw' drive sts =
+  window [ text <+ val "Drawing Editor" ] $
+      canvas [ size (sizeX,sizeY)
+             , drawing      <+ draw    +< sts
+             , mouseClick   +> click   >+ sink drive
+             , mouseRelease +> release >+ sink drive
+             , mouse        +> move    >+ sink drive
+             ]
+    .^^
+    ( button [ text     <+ val "Clear"
+             , activate +> const clear >+ sink drive
+             ]
+  .<< button [ text     <+ val "Undo"
+             , activate +> const undo  >+ sink drive
+             ]
+    )
+
+-------------------------------------------------------------------------
+
+data State
+  = State
+  { linez   :: [(Point,Point)]
+  , current :: Maybe (Point,Point)
+  }
+ deriving ( Eq, Show, Read )
+
+clean :: State
+clean = State{ linez = [], current = Nothing }
+
+click :: Point -> State -> State
+click p st = st{ current = Just (p,p) }
+
+move :: Point -> State -> State
+move p st = case current st of
+              Nothing     -> st
+              Just (p1,_) -> st{ current = Just (p1,p) }
+
+release :: Point -> State -> State
+release p st = case current st of
+                 Nothing     -> st
+                 Just (p1,_) -> st{ linez   = (p1,p) : linez st
+                                  , current = Nothing
+                                  }
+
+clear :: State -> State
+clear st = clean
+
+undo :: State -> State
+undo st = st{ linez = drop 1 (linez st) }
+
+draw :: State -> Drawing
+draw st = drawings $
+  [ Line p1 p2
+  | (p1,p2) <- linez st
+  ] ++
+  [ Context (fgColor red) (Line p1 p2)
+  | Just (p1,p2) <- [current st]
+  ] 
+ where
+  red   = rgb 65535 0 0
+
+-------------------------------------------------------------------------
+
addfile ./Examples/Hello.hs
hunk ./Examples/Hello.hs 1
+module Main where
+
+----------------------------------------------------------------------------
+
+import Graphics.UI.Fui
+
+----------------------------------------------------------------------------
+
+main :: IO ()
+main = run hello
+
+----------------------------------------------------------------------------
+
+hello :: GUI
+hello =
+ channel $ \name ->
+ channel $ \click ->
+   window [ text <+ val "Hej" ]
+   ( label  [ text     <+ (greet `fmap` put "" (source name)) `when` source click ]
+ .^^ entry  [ text     +> sink name ]
+ .^^ button [ text     <+ val "Hello"
+            , activate +> sink click
+            ]
+   )
+ where
+  greet s = "Hello, " ++ s ++ "!"
+
+----------------------------------------------------------------------------
adddir ./Graphics
adddir ./Graphics/UI
adddir ./Graphics/UI/Fui
addfile ./Graphics/UI/Fui.hs
hunk ./Graphics/UI/Fui.hs 1
+module Graphics.UI.Fui
+  ( module Graphics.UI.Fui.Stream
+  , module Graphics.UI.Fui.Sink
+  , module Graphics.UI.Fui.GUI
+  , module Graphics.UI.Fui.Widget
+  )
+ where
+
+----------------------------------------------------------------------------
+
+import Graphics.UI.Fui.Stream
+import Graphics.UI.Fui.Sink
+import Graphics.UI.Fui.GUI
+import Graphics.UI.Fui.Widget
+
+----------------------------------------------------------------------------
+
addfile ./Graphics/UI/Fui/Event.hs
hunk ./Graphics/UI/Fui/Event.hs 1
+module Graphics.UI.Fui.Event
+  ( Event    -- :: * -> *; Functor
+  , never    -- :: Event a
+  , (\/)     -- :: Event a -> Event a -> Event a
+  , triggers -- :: Event a -> Sink a -> IO ()
+  , newEvent -- :: IO (Event a, Sink a)
+  )
+ where
+
+----------------------------------------------------------------------------
+
+import Graphics.UI.Fui.Sink
+import Graphics.UI.Fui.Later
+import Graphics.UI.Fui.Time
+
+----------------------------------------------------------------------------
+
+data Event a
+  = Later Time a
+  | Event a :\/ Event a
+  | Never
+
+instance Functor Event where
+  f `fmap` Never       = Never
+  f `fmap` Later t x   = Later t (f x)
+  f `fmap` (e1 :\/ e2) = (f `fmap` e1) :\/ (f `fmap` e2)
+
+newEvent :: IO (Event a, Sink a)
+newEvent =
+  do t       <- newTime
+     (x,def) <- later
+     return (Later t x, \x -> do def x; pin t)
+
+occurred :: Event a -> IO (Maybe (Integer,a))
+occurred Never       = return Nothing
+occurred (Later t x) = fmap (\n -> (n,x)) `fmap` inspect t
+occurred (e1 :\/ e2) =
+  do mtx1 <- occurred e1
+     mtx2 <- occurred e2
+     case (mtx1, mtx2) of
+       (Just (t1,x1), Just (t2,x2))
+         | t1 <= t2                 -> return mtx1
+         | otherwise                -> return mtx2
+       (Just (t1,x2), _)            -> return mtx1
+       (_           , Just (t2,x2)) -> return mtx2
+       (_           , _)            -> return Nothing
+
+triggers :: Event a -> (a -> IO ()) -> IO ()
+Never           `triggers` _ = return ()
+Later t x       `triggers` k = k x `at` t
+evt@(e1 :\/ e2) `triggers` k =
+  do mtx <- occurred evt
+     case mtx of
+       Just (_,x) -> k x
+       Nothing    -> do (evt',arr') <- newEvent
+                        evt' `triggers` k
+                        e1   `triggers` arr'
+                        e2   `triggers` arr'
+
+never :: Event a
+never = Never
+
+(\/) :: Event a -> Event a -> Event a
+Never \/ evt   = evt
+evt   \/ Never = evt
+evt1  \/ evt2  = evt1 :\/ evt2
+
+----------------------------------------------------------------------------
+
addfile ./Graphics/UI/Fui/GUI.hs
hunk ./Graphics/UI/Fui/GUI.hs 1
+module Graphics.UI.Fui.GUI where
+
+----------------------------------------------------------------------------
+
+import Graphics.UI.Fui.Stream
+import Graphics.UI.Fui.Sink
+
+----------------------------------------------------------------------------
+
+import qualified Graphics.UI.Gtk as Gtk
+
+----------------------------------------------------------------------------
+
+infix  3 +>, <+
+
+----------------------------------------------------------------------------
+-- layout
+
+data Layout
+  = Layout :<< Layout
+  | Layout :^^ Layout
+  | Widget Gtk.Widget
+  | Empty
+
+pack :: Layout -> IO Gtk.Widget
+pack lay =
+  case lay of
+    Widget w -> return w
+    _ :<< _  -> do box <- Gtk.hBoxNew False 3
+                   sequence_ [ do w <- pack l
+                                  Gtk.containerAdd box w
+                             | l <- horiz lay 
+                             ]
+                   return (Gtk.toWidget box)
+    _ :^^ _  -> do box <- Gtk.vBoxNew False 3
+                   sequence_ [ do w <- pack l
+                                  Gtk.containerAdd box w
+                             | l <- verti lay 
+                             ]
+                   return (Gtk.toWidget box)
+    Empty    -> do dummy <- Gtk.drawingAreaNew
+                   dummy `Gtk.onSizeRequest` return (Gtk.Requisition 1 1)
+                   return (Gtk.toWidget dummy)
+ where
+  horiz Empty       = []
+  horiz (l1 :<< l2) = horiz l1 ++ horiz l2
+  horiz w           = [w]
+
+  verti Empty       = []
+  verti (l1 :^^ l2) = verti l1 ++ verti l2
+  verti w           = [w]
+
+----------------------------------------------------------------------------
+-- attr
+
+data Attr w a
+  = MkAttr (w -> Sink a -> IO ()) (w -> Stream a -> IO ())
+
+newtype Prop w
+  = MkProp (w -> IO ())
+
+(+>) :: Attr w a -> Sink a -> Prop w
+MkAttr fsnk _ +> snk = MkProp (\w -> fsnk w snk)
+
+(<+) :: Attr w a -> Stream a -> Prop w
+MkAttr _ fsrc <+ src = MkProp (\w -> fsrc w src)
+
+{-
+-- derived
+
+(+>>) :: Attr w a -> Channel a -> Prop w
+attr +>> ch = attr +> sink ch
+
+(<<+) :: Attr w a -> Channel a -> Prop w
+attr <<+ ch = attr <+ source ch
+
+(<+=) :: Attr w a -> a -> Prop w
+attr <+= x = attr <+ val x
+-}
+
+-- specific attributes
+
+class Sized w where
+  size :: (Int,Int) -> Prop w
+
+class Active w where
+  activate :: Attr w ()
+
+class Text w where
+  text :: Attr w String
+
+class Container w where
+  value :: Attr (w a) a
+
+----------------------------------------------------------------------------
+-- channel
+
+data Channel a = MkChannel{ source :: Stream a, sink :: Sink a }
+
+newChannel :: IO (Channel a)
+newChannel =
+  do (src,snk) <- newStream
+     return (MkChannel src snk)
+
+channel :: (Channel a -> GUI) -> GUI
+channel f = action (do ch <- newChannel; return (f ch))
+
+----------------------------------------------------------------------------
+-- GUI
+
+newtype GUI = MkGUI (IO Layout)
+
+action :: IO GUI -> GUI
+action ioGui = MkGUI (do MkGUI gui <- ioGui; gui)
+
+empty :: GUI
+empty = MkGUI (return Empty)
+
+(.<<), (.^^) :: GUI -> GUI -> GUI
+(.<<) = layoutCombo (:<<)
+(.^^) = layoutCombo (:^^)
+
+layoutCombo op (MkGUI gui1) (MkGUI gui2) =
+  MkGUI $
+  do ws1 <- gui1
+     ws2 <- gui2
+     return (ws1 `op` ws2)
+
+run :: GUI -> IO ()
+run (MkGUI gui) =
+  do Gtk.initGUI
+     gui
+     Gtk.mainGUI
+
+----------------------------------------------------------------------------
+
+
addfile ./Graphics/UI/Fui/Later.hs
hunk ./Graphics/UI/Fui/Later.hs 1
+module Graphics.UI.Fui.Later where
+
+----------------------------------------------------------------------------
+
+import Data.IORef
+import System.IO.Unsafe( unsafeInterleaveIO ) -- oh, well
+
+----------------------------------------------------------------------------
+{-
+
+The function "later" is a variant of the function fixIO. It provides access
+to a value before the value is actually defined. When we create the value,
+we also create a function that needs to be used to define the value:
+
+  later :: IO (a, a -> IO ())
+
+If the value is evaluated before it is defined, then the program loops
+(much like in other programs that are too strict).
+
+Typical use:
+
+  do (x,def_x) <- later
+
+     .. do something with x (without evaluating it) ..
+
+     def_x 42
+
+     .. now we can evaluate x, which has the value 42 ..
+
+Example 1 (OK use):
+
+  do (xs,def_xs) <- later
+     def_xs ('a' : xs)
+     print (take 50 xs)
+
+Example 2 (OK use):
+
+  do (xs,def_xs) <- later
+     def_xs ('a' : xs)
+     def_xs "cow" -- this is ignored, only the first definition counts
+     print (take 50 xs)
+
+Example 3 (bad use (s is never defined), loops):
+
+  do (s,def_s) <- later
+     print (s :: String)
+
+Example 4 (bad use (too strict in x), loops):
+
+  do (x,def_x) <- later
+     print x
+     def_x 42
+
+Example 5 (bad use (too strict in x), loops):
+
+  do (x,def_x) <- later
+     if x then def_x False
+          else def_x True
+     print (x :: Bool)
+
+-}
+----------------------------------------------------------------------------
+-- later
+
+later :: IO (a, a -> IO ())
+later =
+  do ref <- newIORef Nothing
+     
+     let get =
+           do mx <- readIORef ref
+              case mx of
+                Just x  -> return x
+                Nothing -> loop
+     
+         def x =
+           do mx <- readIORef ref
+              case mx of
+                Just _  -> return ()
+                Nothing -> writeIORef ref (Just x)
+     
+     x <- unsafeInterleaveIO get
+     return (x, def)
+ where
+  -- this should really loop, but that is so hard to debug!
+  loop = error "sooner rather than later"
+
+----------------------------------------------------------------------------
+
addfile ./Graphics/UI/Fui/Sink.hs
hunk ./Graphics/UI/Fui/Sink.hs 1
+module Graphics.UI.Fui.Sink
+  ( Sink    -- :: * -> *
+  , mapSink -- :: (b -> a) -> Sink a -> Sink b
+  , hole    -- :: Sink a
+  , send    -- :: Sink a -> a -> IO ()
+  , (/\)    -- :: Sink a -> Sink a -> Sink a
+  , (>+), (>!+), stdio, stdout
+  )
+ where
+
+infixr 4 >+, >!+
+
+----------------------------------------------------------------------------
+-- sink
+
+-- sinks are actions that can receive values
+
+type Sink a
+  = a -> IO ()
+
+----------------------------------------------------------------------------
+
+mapSink, (>+) :: (b -> a) -> Sink a -> Sink b
+mapSink f k = k . f
+(>+)        = mapSink
+
+(>!+) :: (b -> IO a) -> Sink a -> Sink b
+f >!+ snk = \x -> do y <- f x; snk y
+
+hole :: Sink a
+hole = \_ -> return ()
+
+send :: Sink a -> a -> IO ()
+send k = k
+
+(/\) :: Sink a -> Sink a -> Sink a
+k1 /\ k2 = \x -> k1 x >> k2 x
+
+stdio :: Sink (IO ())
+stdio = id
+
+stdout :: Show a => Sink a
+stdout = print
+
+----------------------------------------------------------------------------
+
addfile ./Graphics/UI/Fui/Stream.hs
hunk ./Graphics/UI/Fui/Stream.hs 1
+module Graphics.UI.Fui.Stream
+  ( Stream    -- :: * -> *; Functor
+  , nil       -- :: Stream a
+  , put       -- :: a -> Stream a -> Stream a
+  , val       -- :: a -> Stream a
+  , get       -- :: Stream a -> (a -> Stream a -> Stream b) -> Stream b
+  , (><)      -- :: Stream a -> Stream a -> Stream a
+  , wait      -- :: Event a -> (a -> Stream b) -> Stream b
+  , flush     -- :: Stream a -> Sink a -> IO ()
+  , newStream -- :: IO (Stream a, Sink a)
+  
+  , sync', when', sync, when, fold, (+<)
+  )
+ where
+
+----------------------------------------------------------------------------
+
+import Graphics.UI.Fui.Sink
+import Graphics.UI.Fui.Event
+import Control.Exception
+
+----------------------------------------------------------------------------
+
+import Data.IORef
+
+----------------------------------------------------------------------------
+
+infixl 4 +<
+
+----------------------------------------------------------------------------
+-- stream
+
+-- a stream is a possibly infinite stream of values, that can wait
+-- for events every now and then
+
+data Stream a
+  = a :> Stream a
+  | Wait (Event (Stream a))
+
+instance Functor Stream where
+  fmap f (x :> str) = f x :> fmap f str
+  fmap f (Wait evt) = Wait (fmap f `fmap` evt)
+
+(+<) :: Functor f => (a -> b) -> f a -> f b
+f +< m = fmap f m
+
+----------------------------------------------------------------------------
+
+put :: a -> Stream a -> Stream a
+put x str = x :> str
+
+nil :: Stream a
+nil = Wait never
+
+val :: a -> Stream a
+val x = put x nil
+
+wait :: Event a -> (a -> Stream b) -> Stream b
+wait evt f = Wait (f `fmap` evt)
+
+get :: Stream a -> (a -> Stream a -> Stream b) -> Stream b
+get (x :> str) f = f x str
+get (Wait evt) f = wait evt (\str' -> get str' f)
+
+(><) :: Stream a -> Stream a -> Stream a
+(x :> str1)      >< str2             = x :> (str1 >< str2)
+str1             >< (y :> str2)      = y :> (str1 >< str2)
+str1@(Wait evt1) >< str2@(Wait evt2) =
+  Wait (fmap (>< str2) evt1 \/ fmap (str1 ><) evt2)
+
+sync' :: a -> Stream a -> Stream b -> Stream (a,b)
+sync' a as bs = find a (fmap Left as >< fmap Right bs)
+ where
+  find a s = get s $ \eab s' -> case eab of
+                                  Left a' -> find a' s'
+                                  Right b -> put (a,b) (find a s')
+
+when' :: a -> Stream a -> Stream b -> Stream a
+when' a as bs = fmap fst (sync' a as bs)
+
+sync :: Stream a -> Stream b -> Stream (a,b)
+sync = sync' (error "sync")
+
+when :: Stream a -> Stream b -> Stream a
+when = when' (error "when")
+
+fold :: (a -> b -> b) -> b -> Stream a -> Stream b
+fold op x as = put x $ get as $ \a as' -> fold op (a `op` x) as' 
+
+snapshot :: Stream a -> Stream (Stream a)
+snapshot s = get s $ \x s' -> put s (snapshot s')
+
+join :: Stream (Stream a) -> Stream a
+join ssa = get ssa $ \sa ssa' -> sa >< join ssa'
+
+----------------------------------------------------------------------------
+-- stream --> sink
+
+-- sending all elements in a stream to a sink (as soon as they are available)
+
+flush :: Stream a -> Sink a -> IO ()
+flush (x :> str) snk = do send snk x; flush str snk
+flush (Wait evt) snk = do evt `triggers` \str -> flush str snk
+
+----------------------------------------------------------------------------
+-- sink --> stream
+
+-- creating a stream, together with a sink that makes elements appear
+-- in the stream
+
+newStream :: IO (Stream a, Sink a)
+newStream =
+  do (evt,arr) <- newEvent
+     ref <- newIORef arr
+     let snk x =
+           do arr <- readIORef ref
+              (evt',arr') <- newEvent
+              writeIORef ref arr'
+              send arr (x :> Wait evt')
+      in return (Wait evt,snk)
+
+----------------------------------------------------------------------------
+
addfile ./Graphics/UI/Fui/Time.hs
hunk ./Graphics/UI/Fui/Time.hs 1
+module Graphics.UI.Fui.Time where
+
+----------------------------------------------------------------------------
+
+import Data.IORef
+import System.CPUTime
+
+----------------------------------------------------------------------------
+
+data Time
+  = MkTime (IORef (Either (IO ()) Integer))
+
+newTime :: IO Time
+newTime =
+  do ref <- newIORef (Left (return ()))
+     return (MkTime ref)
+
+pin :: Time -> IO ()
+pin (MkTime ref) =
+  do eat <- readIORef ref
+     case eat of
+       Left action ->
+         do t <- getCPUTime
+            writeIORef ref (Right t)
+            action
+
+       Right _ -> -- already happened
+         do return ()
+
+at :: IO () -> Time -> IO ()
+action `at` MkTime ref =
+  do eat <- readIORef ref
+     case eat of
+       Left action' ->
+         do writeIORef ref (Left (action' >> action))
+       
+       Right t -> -- already happened
+         do action
+
+inspect :: Time -> IO (Maybe Integer)
+inspect (MkTime ref) =
+  do eat <- readIORef ref
+     return (case eat of
+               Left _  -> Nothing
+               Right t -> Just t)
+
+----------------------------------------------------------------------------
+
adddir ./Graphics/UI/Fui/Widget
addfile ./Graphics/UI/Fui/Widget.hs
hunk ./Graphics/UI/Fui/Widget.hs 1
+module Graphics.UI.Fui.Widget
+  ( module Graphics.UI.Fui.Widget.Window
+  , module Graphics.UI.Fui.Widget.Button
+  , module Graphics.UI.Fui.Widget.Label
+  , module Graphics.UI.Fui.Widget.Entry
+  , module Graphics.UI.Fui.Widget.Canvas
+  , module Graphics.UI.Fui.Widget.Timer
+  , module Graphics.UI.Fui.Widget.Dynamic
+  , module Graphics.UI.Fui.Widget.Connect
+  )
+ where
+
+----------------------------------------------------------------------------
+
+import Graphics.UI.Fui.Widget.Window
+import Graphics.UI.Fui.Widget.Button
+import Graphics.UI.Fui.Widget.Label
+import Graphics.UI.Fui.Widget.Entry
+import Graphics.UI.Fui.Widget.Canvas
+import Graphics.UI.Fui.Widget.Timer
+import Graphics.UI.Fui.Widget.Dynamic
+import Graphics.UI.Fui.Widget.Connect
+
+----------------------------------------------------------------------------
+
addfile ./Graphics/UI/Fui/Widget/Button.hs
hunk ./Graphics/UI/Fui/Widget/Button.hs 1
+module Graphics.UI.Fui.Widget.Button where
+
+----------------------------------------------------------------------------
+
+import Graphics.UI.Fui.Stream
+import Graphics.UI.Fui.Sink
+import Graphics.UI.Fui.GUI
+
+----------------------------------------------------------------------------
+
+import qualified Graphics.UI.Gtk as Gtk
+
+----------------------------------------------------------------------------
+
+data Button
+  = MkButton Gtk.Button (Channel String)
+
+button :: [Prop Button] -> GUI
+button props =
+  MkGUI $
+  do but <- Gtk.buttonNew
+     chaText <- newChannel
+     let w = MkButton but chaText
+     sequence_ [ prop w | MkProp prop <- props ]
+     return (Widget (Gtk.toWidget but))
+
+instance Sized Button where
+  size (x,y) =
+    MkProp (\(MkButton w _) ->
+      do w `Gtk.onSizeRequest` return (Gtk.Requisition x y)
+         return ()
+    )
+
+instance Active Button where
+  activate = MkAttr
+    (\(MkButton but chaText) snk ->
+      do but `Gtk.onClicked` send snk ()
+         return ()
+    )
+    (\(MkButton but chaText) src ->
+      do flush src (\_ -> Gtk.buttonClicked but)
+    )
+
+instance Text Button where
+  text = MkAttr
+    (\(MkButton but chaText) snk ->
+      do flush (source chaText) snk
+    )
+    (\(MkButton but chaText) src ->
+      do flush src (Gtk.buttonSetLabel but)
+         flush src (sink chaText)
+    )
+
+----------------------------------------------------------------------------
+
addfile ./Graphics/UI/Fui/Widget/Canvas.hs
hunk ./Graphics/UI/Fui/Widget/Canvas.hs 1
+module Graphics.UI.Fui.Widget.Canvas where
+
+----------------------------------------------------------------------------
+
+import Graphics.UI.Fui.Stream
+import Graphics.UI.Fui.Event
+import Graphics.UI.Fui.Sink
+import Graphics.UI.Fui.GUI
+
+----------------------------------------------------------------------------
+
+import qualified Graphics.UI.Gtk as Gtk
+import Data.IORef
+
+----------------------------------------------------------------------------
+
+type Point = (Int,Int)
+
+data Canvas
+  = MkCanvas Gtk.DrawingArea (Event Gtk.DrawWindow) (Channel Drawing) (Channel Point) (Channel Point) (Channel Point)
+
+canvas :: [Prop Canvas] -> GUI
+canvas props =
+  MkGUI $
+  do can <- Gtk.drawingAreaNew
+     chaDraw      <- newChannel
+     getLastDraw  <- mkGetLast chaDraw (drawings [])
+     chaClick     <- newChannel
+     chaRel       <- newChannel
+     chaMouse     <- newChannel
+     (evtDrw,drw) <- newEvent
+     can `Gtk.onExpose` \_ ->
+       do dw <- Gtk.widgetGetDrawWindow can
+          send drw dw
+          dr <- getLastDraw
+          drawDrawing dw dr
+          return True
+     let w = MkCanvas can evtDrw chaDraw chaClick chaRel chaMouse
+     sequence_ [ prop w | MkProp prop <- props ]
+     return (Widget (Gtk.toWidget can))
+ where
+  mkGetLast ch x =
+    do ref <- newIORef x
+       source ch `flush` writeIORef ref
+       return (readIORef ref)
+
+instance Sized Canvas where
+  size (x,y) =
+    MkProp (\(MkCanvas w _ _ _ _ _) ->
+      do w `Gtk.onSizeRequest` return (Gtk.Requisition x y)
+         return ()
+    )
+
+--
+
+sizeDr :: Drawing -> Int
+sizeDr (Context _ d) = sizeDr d
+sizeDr (Drawings ds) = sum (map sizeDr ds)
+sizeDr _             = 1
+
+data Drawing
+  = Line Point Point
+  | Slice Bool Point (Int,Int) (Int,Int)
+  | Context Context Drawing
+  | Drawings [Drawing]
+
+line :: Point -> Point -> Drawing
+line p1 p2 = Line p1 p2
+
+lines :: [Point] -> Drawing
+lines ps = drawings [ line p1 p2 | (p1,p2) <- ps `zip` drop 1 ps ]
+
+circle :: Bool -> Point -> Int -> Drawing
+circle f p r = Slice f p (r,r) (0,64*360)
+
+drawings :: [Drawing] -> Drawing
+drawings ds = Drawings ds
+
+type Context = Gtk.GCValues -> Gtk.GCValues
+type Color   = Gtk.Color
+
+fgColor, bgColor :: Color -> Context
+fgColor c gv = gv{ Gtk.foreground = c }
+bgColor c gv = gv{ Gtk.background = c }
+
+rgb = Gtk.Color
+
+context :: Context -> Drawing -> Drawing
+context ctx d = Context ctx d
+
+drawing :: Attr Canvas Drawing
+drawing = MkAttr
+  (\(MkCanvas can drwEvt chaDraw chaClick chaRel chaMouse) snk ->
+    do flush (source chaDraw) snk
+  )
+  (\(MkCanvas can drwEvt chaDraw chaClick chaRel chaMouse) src ->
+    do flush src $ \drw ->
+         drwEvt `triggers` \dw ->
+           do drawDrawing dw drw
+       flush src (sink chaDraw)
+  )
+
+drawDrawing :: Gtk.DrawWindow -> Drawing -> IO ()
+drawDrawing dw d =
+  do Gtk.drawWindowClear dw
+     gc <- Gtk.gcNew dw
+     let draw (Line p1 p2)                    = Gtk.drawLine dw gc p1 p2
+         draw (Slice f (x,y) (rx,ry) (d1,d2)) = Gtk.drawArc dw gc f (x-rx) (y-ry) (2*rx) (2*ry) d1 d2
+         draw (Drawings ds)                   = sequence_ [ draw d | d <- ds ]
+         draw (Context k d)                   = do vs <- Gtk.gcGetValues gc
+                                                   Gtk.gcSetValues gc (k vs)
+                                                   draw d
+                                                   Gtk.gcSetValues gc vs
+      in draw d
+
+mouseClick :: Attr Canvas Point
+mouseClick = MkAttr
+  (\(MkCanvas can _ chaDraw chaClick chaRel chaMouse) snk ->
+    do can `Gtk.onButtonPress` \_ ->
+         do p <- Gtk.widgetGetPointer can
+            send snk p
+            return True
+       flush (source chaClick) snk
+  )
+  (\(MkCanvas can _ chaDraw chaClick chaRel chaMouse) src ->
+    do flush src (sink chaClick)
+  )
+
+mouseRelease :: Attr Canvas Point
+mouseRelease = MkAttr
+  (\(MkCanvas can _ chaDraw chaClick chaRel chaMouse) snk ->
+    do can `Gtk.onButtonRelease` \_ ->
+         do p <- Gtk.widgetGetPointer can
+            send snk p
+            return True
+       flush (source chaRel) snk
+  )
+  (\(MkCanvas can _ chaDraw chaClick chaRel chaMouse) src ->
+    do flush src (sink chaRel)
+  )
+
+mouse :: Attr Canvas Point
+mouse = MkAttr
+  (\(MkCanvas can _ chaDraw chaClick chaRel chaMouse) snk ->
+    do Gtk.onMotionNotify can True $ \_ ->
+         do p <- Gtk.widgetGetPointer can
+            send snk p
+            return True
+       flush (source chaMouse) snk
+  )
+  (\(MkCanvas can _ chaDraw chaClick chaRel chaMouse) src ->
+    do flush src (sink chaMouse)
+  )
+
+----------------------------------------------------------------------------
+
addfile ./Graphics/UI/Fui/Widget/Connect.hs
hunk ./Graphics/UI/Fui/Widget/Connect.hs 1
+module Graphics.UI.Fui.Widget.Connect where
+
+----------------------------------------------------------------------------
+
+import Graphics.UI.Fui.Stream
+import Graphics.UI.Fui.Sink
+import Graphics.UI.Fui.GUI
+
+----------------------------------------------------------------------------
+
+infix 3 +>+
+
+----------------------------------------------------------------------------
+
+(+>+) :: Stream a -> Sink a -> GUI
+str +>+ snk = action (do flush str snk; return empty)
+
+----------------------------------------------------------------------------
+
addfile ./Graphics/UI/Fui/Widget/Dynamic.hs
hunk ./Graphics/UI/Fui/Widget/Dynamic.hs 1
+module Graphics.UI.Fui.Widget.Dynamic where
+
+----------------------------------------------------------------------------
+
+import Graphics.UI.Fui.Stream
+import Graphics.UI.Fui.Sink
+import Graphics.UI.Fui.GUI
+
+----------------------------------------------------------------------------
+
+import qualified Graphics.UI.Gtk as Gtk
+
+----------------------------------------------------------------------------
+
+dynamic :: Stream GUI -> GUI
+dynamic srcGUI =
+  MkGUI $
+  do box <- Gtk.vBoxNew False 0
+     wid <- pack Empty
+     Gtk.containerAdd box wid
+     flush srcGUI $ \(MkGUI gui) ->
+       do Gtk.containerForeach box $ \wid ->
+            do Gtk.containerRemove box wid
+               --Gtk.widgetDestroy w
+          lay <- gui
+          wid <- pack lay
+          Gtk.containerAdd box wid
+          Gtk.widgetShowAll box
+     return (Widget (Gtk.toWidget box))
+
+----------------------------------------------------------------------------
+
addfile ./Graphics/UI/Fui/Widget/Entry.hs
hunk ./Graphics/UI/Fui/Widget/Entry.hs 1
+module Graphics.UI.Fui.Widget.Entry where
+
+----------------------------------------------------------------------------
+
+import Graphics.UI.Fui.Stream
+import Graphics.UI.Fui.Sink
+import Graphics.UI.Fui.GUI
+
+----------------------------------------------------------------------------
+
+import qualified Graphics.UI.Gtk as Gtk
+
+----------------------------------------------------------------------------
+
+data Entry
+  = MkEntry Gtk.Entry (Channel ()) (Channel String)
+
+entry :: [Prop Entry] -> GUI
+entry props =
+  MkGUI $
+  do ent <- Gtk.entryNew
+     chaAct  <- newChannel
+     chaText <- newChannel
+     let w = MkEntry ent chaAct chaText
+     sequence_ [ prop w | MkProp prop <- props ]
+     return (Widget (Gtk.toWidget ent))
+
+instance Sized Entry where
+  size (x,y) =
+    MkProp (\(MkEntry w _ _) ->
+      do w `Gtk.onSizeRequest` return (Gtk.Requisition x y)
+         return ()
+    )
+
+instance Active Entry where
+  activate = MkAttr
+    (\(MkEntry ent chaAct chaText) snk ->
+      do ent `Gtk.onEntryActivate` send snk ()
+         flush (source chaAct) snk
+    )
+    (\(MkEntry ent chaAct chaText) src ->
+      do flush src (sink chaAct)
+    )
+
+instance Text Entry where
+  text = MkAttr
+    (\(MkEntry ent chaAct chaText) snk ->
+      do ent `Gtk.onKeyRelease` \_ ->
+           do s <- Gtk.entryGetText ent
+              send snk s
+              return False
+         flush (source chaText) snk
+    )
+    (\(MkEntry ent chaAct chaText) src ->
+      do flush src (Gtk.entrySetText ent)
+         flush src (sink chaText)
+    )
+
+----------------------------------------------------------------------------
+
+data TEntry a
+  = MkTEntry Gtk.Entry (Channel ()) (Channel a) (a -> String) (String -> Maybe a)
+
+tentry :: (Show a, Read a) => [Prop (TEntry a)] -> GUI
+tentry props =
+  MkGUI $
+  do ent <- Gtk.entryNew
+     chaAct <- newChannel
+     chaVal <- newChannel
+     let w = MkTEntry ent chaAct chaVal show readMaybe
+     sequence_ [ prop w | MkProp prop <- props ]
+     return (Widget (Gtk.toWidget ent))
+ where
+  readMaybe s = case reads s of
+                  (x,""):_ -> Just x
+                  _        -> Nothing
+
+instance Sized (TEntry a) where
+  size (x,y) =
+    MkProp (\(MkTEntry w _ _ _ _) ->
+      do w `Gtk.onSizeRequest` return (Gtk.Requisition x y)
+         return ()
+    )
+
+instance Active (TEntry a) where
+  activate = MkAttr
+    (\(MkTEntry ent chaAct chaVal show read) snk ->
+      do ent `Gtk.onEntryActivate` send snk ()
+         flush (source chaAct) snk
+    )
+    (\(MkTEntry ent chaAct chaVal show read) src ->
+      do flush src (sink chaAct)
+    )
+
+instance Container TEntry where
+  value = MkAttr
+    (\(MkTEntry ent chaAct chaVal show read) snk ->
+      do ent `Gtk.onKeyRelease` \_ ->
+           do s <- Gtk.entryGetText ent
+              case read s of
+                Just x  -> send snk x
+                Nothing -> return ()
+              return False
+         flush (source chaVal) snk
+    )
+    (\(MkTEntry ent chaAct chaVal show read) src ->
+      do flush src (Gtk.entrySetText ent . show)
+         flush src (sink chaVal)
+    )
+
+----------------------------------------------------------------------------
+
addfile ./Graphics/UI/Fui/Widget/IO.hs
hunk ./Graphics/UI/Fui/Widget/IO.hs 1
+module Graphics.UI.Fui.Widget.Connect where
+
+----------------------------------------------------------------------------
+
+import Graphics.UI.Fui.Stream
+import Graphics.UI.Fui.Sink
+import Graphics.UI.Fui.GUI
+
+----------------------------------------------------------------------------
+
+(+>+) :: Stream a -> Sink a -> GUI
+str +>+ snk = action (do flush str snk; return Empty)
+
+----------------------------------------------------------------------------
+
addfile ./Graphics/UI/Fui/Widget/Label.hs
hunk ./Graphics/UI/Fui/Widget/Label.hs 1
+module Graphics.UI.Fui.Widget.Label where
+
+----------------------------------------------------------------------------
+
+import Graphics.UI.Fui.Stream
+import Graphics.UI.Fui.Sink
+import Graphics.UI.Fui.GUI
+
+----------------------------------------------------------------------------
+
+import qualified Graphics.UI.Gtk as Gtk
+
+----------------------------------------------------------------------------
+
+data Label
+  = MkLabel Gtk.Label (Channel String)
+
+label :: [Prop Label] -> GUI
+label props =
+  MkGUI $
+  do lab <- Gtk.labelNew Nothing
+     chaText <- newChannel
+     let w = MkLabel lab chaText
+     sequence_ [ prop w | MkProp prop <- props ]
+     return (Widget (Gtk.toWidget lab))
+
+instance Sized Label where
+  size (x,y) =
+    MkProp (\(MkLabel w _) ->
+      do w `Gtk.onSizeRequest` return (Gtk.Requisition x y)
+         return ()
+    )
+
+instance Text Label where
+  text = MkAttr
+    (\(MkLabel lab chaText) snk ->
+      do flush (source chaText) snk
+    )
+    (\(MkLabel lab chaText) src ->
+      do flush src (Gtk.labelSetText lab)
+         flush src (sink chaText)
+    )
+
+----------------------------------------------------------------------------
+
addfile ./Graphics/UI/Fui/Widget/Timer.hs
hunk ./Graphics/UI/Fui/Widget/Timer.hs 1
+module Graphics.UI.Fui.Widget.Timer where
+
+----------------------------------------------------------------------------
+
+import Graphics.UI.Fui.Stream
+import Graphics.UI.Fui.Sink
+import Graphics.UI.Fui.GUI
+
+----------------------------------------------------------------------------
+
+import qualified Graphics.UI.Gtk as Gtk
+
+----------------------------------------------------------------------------
+
+data Timer
+  = MkTimer (Channel ())
+
+timer :: Int -> [Prop Timer] -> GUI
+timer t props =
+  MkGUI $
+  do chaAct <- newChannel
+     Gtk.timeoutAdd (send (sink chaAct) () >> return True) t
+     let w = MkTimer chaAct
+     sequence_ [ prop w | MkProp prop <- props ]
+     return Empty
+
+instance Active Timer where
+  activate = MkAttr
+    (\(MkTimer chaAct) snk ->
+      do flush (source chaAct) snk
+    )
+    (\(MkTimer chaAct) src ->
+      do flush src (sink chaAct)
+    )
+
+----------------------------------------------------------------------------
+
addfile ./Graphics/UI/Fui/Widget/Window.hs
hunk ./Graphics/UI/Fui/Widget/Window.hs 1
+module Graphics.UI.Fui.Widget.Window where
+
+----------------------------------------------------------------------------
+
+import Graphics.UI.Fui.Stream
+import Graphics.UI.Fui.Sink
+import Graphics.UI.Fui.GUI
+
+----------------------------------------------------------------------------
+
+import qualified Graphics.UI.Gtk as Gtk
+
+----------------------------------------------------------------------------
+
+data Window
+  = MkWindow Gtk.Window (Channel String)
+
+window :: [Prop Window] -> GUI -> GUI
+window props (MkGUI gui) =
+  MkGUI $
+  do win <- Gtk.windowNew
+     win `Gtk.onDestroy` Gtk.mainQuit
+     chaTitle <- newChannel
+     let w = MkWindow win chaTitle
+     sequence_ [ prop w | MkProp prop <- props ]
+     lay <- gui
+     wid <- pack lay
+     Gtk.containerAdd win wid
+     Gtk.widgetShowAll win
+     return Empty
+
+instance Sized Window where
+  size (x,y) =
+    MkProp (\(MkWindow w _) ->
+      do w `Gtk.onSizeRequest` return (Gtk.Requisition x y)
+         return ()
+    )
+
+instance Text Window where
+  text = MkAttr
+    (\(MkWindow win chaTitle) snk ->
+      do flush (source chaTitle) snk
+    )
+    (\(MkWindow win chaTitle) src ->
+      do flush src (Gtk.windowSetTitle win)
+         flush src (sink chaTitle)
+    )
+
+----------------------------------------------------------------------------
+