of {$slidecount} ½ {$title}, {$author}

Title: GTK+ Programming in Haskell Authors: Savanni D'Gerinel Date: 2014-09-25 19:00:00 CDT

TL;DR

TL;DR: The GTK bindings in Haskell are analogous to the C standard bindings. This allows you to do a lot of your GTK programming in the same way as normal, with only a few catches.

Illuminance

A High Dynamic Range image processing app for Linux

C Utility Libraries

Cabal

Initializing a GTK Application

initGUI :: IO [String]
builderNew :: IO Builder
builderAddFromFile :: Builder -> FilePath -> IO ()

----

import Graphics.UI.Gtk
import qualified Core as Core

main :: IO ()
main = do
    void $ initGUI
    builder <- builderNew
    builderAddFromFile builder "resources/ui.glade"
    app <- Core.newApp

    window <- builderGetObject builder castToWindow "main-window"
    void $ on window deleteEvent $ liftIO (mainQuit >> return False)

    widgetShowAll window
    mainGUI

Arranging Widgets and Events

builderGetObject :: (GObjectClass cls, GlibString string)
                    => Builder
                    -> (GObject -> cls)
                    -> string
                    -> IO cls

sourceImagesWidget :: AppData -> MessageWidget -> Builder -> IO SourceWidget
sourceImagesWidget app msgW builder = do
    listView <- builderGetObject builder castToTreeView "file-list-view"
    fileListStore <- connectFileListWidget listView
    previewWidget <- builderGetObject builder castToImage "source-preview"

    addFilesButton <- builderGetObject builder castToButton "add-files"
    void $ on addFilesButton buttonActivated $
        runFileChooser (\fn -> void (forkIO $ void (runApp app (addImage fn))))

    ...

Binding Signals

newtype Signal object handler =
    Signal (Bool -> object -> handler -> IO (ConnectId object))

buttonActivated :: ButtonClass self => Signal self (IO ())
sizeAllocate :: WidgetClass self => Signal self (Allocation -> IO ())

on :: object -> Signal object callback -> callback -> IO (ConnectId object)

Composite Widgets

data SourceWidget = SourceWidget {
      sourceContainer :: Graphics.UI.Gtk.HBox
    , sourceMessageW :: Graphics.UI.Gtk.Label
    , sourcePreviewW :: Graphics.UI.Gtk.Image
    , viewLayout :: Graphics.UI.Gtk.Fixed
    }

sourceImagesWidget :: AppData -> MessageWidget -> Builder -> IO SourceWidget
sourceImagesWidget app msgW builder = do
    ...

    return $ SourceWidget container messageWidget previewWidget layout

List Stores and Tree Views

connectFileListWidget :: TreeView -> IO (ListStore (FilePath, LoadStatus FilePath))
connectFileListWidget view = do
    store <- listStoreNew ([] :: [(FilePath, LoadStatus FilePath)])
    treeViewSetModel view store

    column <- treeViewColumnNew
    set column [treeViewColumnTitle := "Filename"]
    renderer <- cellRendererTextNew
    cellLayoutPackStart column renderer False
    cellLayoutSetAttributes column renderer store $
        \(path, status) -> (cellText := takeFileName path) : case status of
            Loading -> [cellTextForeground := "Yellow"]
            ...
    void $ treeViewAppendColumn view column

    return store

Core Application

data AppEvent = ImageListChange | ...
data LoadStatus a = Loading | Loaded a | LoadError PictureLoadError
data AppData = AppData {
      adImagesT     :: TVar (Map FilePath (LoadStatus Picture))
      hdrImageT     :: TVar (Maybe (Image PixelRGBF))
    , observersT    :: TVar [TQueue AppEvent]
    }
newtype AppM a = AppM (ReaderT AppData (EitherT AppError IO) a)
    deriving ...

initAppData :: IO AppData

runApp :: AppData -> AppM a -> IO (Either AppError a)
registerObserver :: AppM (TQueue AppEvent)
addImage :: FilePath -> AppM ()
runHDR :: HDRParameters -> AppM ()
getHDR :: AppM (Maybe (Image PixelRGBF))

Communicating

atomically :: STM a -> IO a
readTVar :: TVar a -> STM a

----

sourceImageList :: AppM [(FilePath, LoadStatus FilePath)]
sourceImageList = do
    AppData{..} <- ask
    liftIO $ atomically $ do
        lst <- M.toList `liftM` readTVar adImagesT
        return -- reformat lst

getHDR :: AppM (Maybe (Image PixelRGBF))
getHDR = ask >>= liftIO . atomically . readTVar . hdrImageT

Communicating

registerObserver :: AppM (TQueue AppEvent)
registerObserver = do
    AppData{..} <- ask
    liftIO $ atomically $ do
        q <- newTQueue
        modifyTVar observersT (q:)
        return q

notifyObservers :: AppData -> AppEvent -> STM ()
notifyObservers AppData{observersT} evt =
    readTVar observersT >>= mapM_ (`writeTQueue` evt)

Communicating

sourceImagesWidget app msgW builder = do
    ...

    eAppEvtQ <- runApp app registerObserver
    _ <- case eAppEvtQ of
        Left err -> error $ show err
        Right appEvtQ -> forkIO $ handleFileListChange app appEvtQ fileListStore

    ...

handleFileListChange :: AppData -> TQueue AppEvent -> ListStore (FilePath, LoadStatus FilePath) -> IO a
handleFileListChange app evtQ fileListStore = forever $ do
    msg <- atomically $ readTQueue evtQ
    case msg of
        ImageListChange -> do
            -- get the list of images
            postGUIAsync $ do
                -- clear the fileListStore, then add each image into
                -- the store along with the current load state
        _ -> return ()

Communicating

runHDR :: AppM ()
runHDR = do
    AppData{..} <- ask
    -- get the current loaded images
    liftIO $ atomically $ notifyObservers AppData{..} HdrRunning
    case calculateHDR loadedPictures of
        Left err -> -- notify all observers of an error
        Right hdr -> liftIO $ do
            atomically $ do
                modifyTVar hdrImageT (const (Just hdr))
                notifyObservers AppData{..} HdrComplete

MVC

Model

data AppData = AppData {
      adImagesT     :: TVar (Map FilePath (LoadStatus Picture))
      hdrImageT     :: TVar (Maybe (Image PixelRGBF))
    , observersT    :: TVar [TQueue AppEvent]
    }

Controller

newtype AppM a = AppM (ReaderT AppData (EitherT AppError IO) a)

runApp :: AppData -> AppM a -> IO (Either AppError a)
registerObserver :: AppM (TQueue AppEvent)
addImage :: FilePath -> AppM ()
runHDR :: HDRParameters -> AppM ()

View

GTK widgets and glue code

Packaging

    installedUI <- doesFileExist "/usr/<whatever>/ui.glade"
    if installedUI
        then builderAddFromFile builder "/usr/<whatever>/ui.glade"
        else builderAddFromFile builder "resources/ui.glade"

Resources