Medium Gtk2Hs Example

This is my non-toy Gtk2Hs exercise. I will explain more in the future.

User manual: The GUI presents an input text box, an output text box, and control buttons. If you input text (may be multi-line) into the input box and press “enter”, the text is given to a String->String function, and its return value is shown in the output box. If the function aborts, the error text is shown instead. If the function takes too long, you may press “break” to stop it. Close the window to quit the program. Limitation: if the return value is an infinite string, no output is shown, and you have to press “break” to stop.

Concepts: text boxes, buttons, event handling, various layouts, full evaluation, exception handling, multi-threading, STM

Build environment at the time of writing: GHC 6.12.3, mtl-1.1.0.2, stm-2.1.2.1, gtk-0.12.0

The Source Code

The main program is as simple as this. Remember to link with -threaded.

 Bool
f n = and [n `mod` d /= 0 | d <- [2..n-1]]
-- or generally any time-consuming partial function
]]>

The GeeInteract module:

 (String -> String) -> IO ()
interact1 title f = do
  initGUI

  -- essential elements
  inpbuf <- textBufferNew Nothing
  inp <- textViewNewWithBuffer inpbuf
  outbuf <- textBufferNew Nothing
  out <- textViewNewWithBuffer outbuf
  inpbut <- buttonNewWithLabel "enter"
  brkbut <- buttonNewWithLabel "break"
  brkbut `set` [widgetSensitive := False]
  clrbut <- buttonNewWithLabel "clear"
  clobut <- buttonNewWithLabel "clear"

  abortbox <- newEmptyTMVarIO
  jobbox <- newEmptyTMVarIO

  inpbut `on` buttonActivated $ do
    inpbut `set` [widgetSensitive := False]
    brkbut `set` [widgetSensitive := True]
    x <- get inpbuf textBufferText
    textBufferSetText outbuf ""
    atomically (putTMVar jobbox (f x))
  brkbut `on` buttonActivated $ do
    atomically (putTMVar abortbox ())
  clrbut `on` buttonActivated $ do
    textBufferSetText inpbuf ""
    widgetGrabFocus inp
  clobut `on` buttonActivated $ do
    textBufferSetText outbuf ""
    widgetGrabFocus inp

  let enable_input = do inpbut `set` [widgetSensitive := True]
                        brkbut `set` [widgetSensitive := False]
                        widgetGrabFocus inp
  supervisor_thread <- forkIO $ forever $ do
    fx <- atomically (takeTMVar jobbox)
    dropbox <- newEmptyTMVarIO
    work_thread <- forkIO (compute fx (atomically . putTMVar dropbox))
    c <- atomically ((takeTMVar abortbox >> return Nothing) `orElse`
                     (Just `fmap` takeTMVar dropbox))
    case c of
      Nothing -> do
        killThread work_thread
        postGUIAsync enable_input
      Just y -> postGUIAsync $ do
        textBufferSetText outbuf (either show id y)
        enable_input

  -- placement elements
  inpframe <- text_and_but inp [clrbut, inpbut, brkbut] "input"

  outframe <- text_and_but out [clobut] "output"

  pane <- vPanedNew
  panedPack1 pane inpframe True True
  panedPack2 pane outframe True True

  top <- windowNew
  set top [windowTitle:=title,
           windowDefaultWidth:=640, windowDefaultHeight:=480]
  top `on` deleteEvent $ liftIO (mainQuit >> return False)
  containerAdd top pane
  widgetGrabFocus inp
  widgetShowAll top
  mainGUI

text_and_but text buts title = do
  scroll <- scrolledWindowNew Nothing Nothing
  containerAdd scroll text

  row <- hBoxNew False 2
  boxSetHomogeneous row False
  boxPackStart row scroll PackGrow 0

  butsbox <- vButtonBoxNew
  set butsbox [boxSpacing := 2, buttonBoxLayoutStyle := ButtonboxStart]
  forM_ buts (containerAdd butsbox)
  boxPackStart row butsbox PackNatural 0

  frame <- frameNew
  set frame [frameLabel := title, frameShadowType := ShadowIn]
  containerAdd frame row

  return frame

compute fx reply = try_all (Ex.evaluate (seq_all fx)) >>= reply

try_all :: IO a -> IO (Either Ex.SomeException a)
try_all = Ex.try

seq_all xs = go xs `seq` xs where
  go [] = ()
  go (x:xs) = x `seq` go xs
]]>

I have more Haskell Notes and Examples