gruff-0.3: src/StatusDialog.hs

module StatusDialog where

import Control.Concurrent (forkIO, killThread)
import Graphics.UI.Gtk

type Status = (String -> IO ()) -> IO ()
data StatusDialog = StatusDialog{ statusDialog :: String -> Status -> IO () }

statusDialogNew :: Pixbuf -> IO StatusDialog
statusDialogNew icon = do
  window <- windowNew
  set window [ windowIcon := Just icon ]
  windowSetModal window True
  windowSetDefaultSize window 320 200
  b <- vBoxNew False 2
  label <- labelNew (Just "")
  cancel <- buttonNewWithLabel "Cancel"
  boxPackStartDefaults b label
  boxPackStartDefaults b cancel
  set window [ containerChild := b ]
  return StatusDialog{ statusDialog = \title task -> postGUIAsync $ do
    windowSetTitle window title
    labelSetText label ""
    widgetSetSensitivity cancel True
    child <- forkIO $ do
      task $ postGUIAsync . labelSetText label
      postGUISync $ widgetHide window
    _ <- cancel `onClicked` do
      killThread child
      widgetHide window
    widgetShowAll window
  }