{-
This is C-like GTK+ code. You can make sense out of this by
reading its tutorial:
http://library.gnome.org/devel/gtk-tutorial/stable
All functions with a c' prefix work exactly like their C
counterpart.
-}
module Gui (doGui) where
import Foreign
import Foreign.C
import Control.Monad
import Bindings.GLib
import Bindings.GObject
import GtkGdk
import Corpora
-- Pango text markup.
choiceStyle = ("" ++) . (++ "")
wordStyle = ("" ++) . (++ "")
textStyle = ("" ++) . (++ "")
labelStyle = ("" ++) . (++ "")
infoStyle = ("" ++) . (++ "")
info = "Press: (1) to select characters on top; (2) to \
\select characters on bottom; (e) for English corpus; \
\(p) for Portuguese corpus; (q) to quit. Selecting '+' \
\finishes a word, selecting '-' erases the current or \
\last word."
doGui :: IO (String,String) -> IO String -> IO String ->
([(String,Integer)] -> IO ()) -> (Either () () -> IO ()) -> IO ()
doGui getChoices getCurrentWord getFullText setCorpus setChoice = do
-- GTK+ init function. Instead of real (argc,argv) we give
-- it 0 and a 0-sized array.
with 0 $ \pArgc -> allocaArray 0 $ \pArgv -> do
c'gtk_init pArgc pArgv
-- Main window. "destroy" event finishes application.
window <- c'gtk_window_new c'GTK_WINDOW_TOPLEVEL
withCString "bitspeak" $ c'gtk_window_set_title (c'GTK_WINDOW window)
withCString "destroy" $ \d -> c'g_signal_connect (castPtr $ c'G_OBJECT window)
d (c'G_CALLBACK p'gtk_main_quit) nullPtr
-- A table layout, populated with a few constant text
-- labels. The remaining code only sees a function used
-- to place widgets in the table.
tableAttach <- do
table <- c'gtk_table_new 5 2 c'TRUE
c'gtk_container_add (c'GTK_CONTAINER window) table
c'gtk_widget_show table
return $ c'gtk_table_attach_defaults (c'GTK_TABLE table)
c'gtk_label_new nullPtr >>= \w -> withCString (labelStyle "Current word:") $ \s ->
c'gtk_label_set_markup (c'GTK_LABEL w) s >> tableAttach w 0 1 2 3 >>
c'gtk_widget_show w
c'gtk_label_new nullPtr >>= \w -> withCString (labelStyle "Full text:") $ \s ->
c'gtk_label_set_markup (c'GTK_LABEL w) s >> tableAttach w 0 1 3 4 >>
c'gtk_widget_show w
c'gtk_label_new nullPtr >>= \w -> withCString (infoStyle info) $ \s ->
c'gtk_label_set_markup (c'GTK_LABEL w) s >> tableAttach w 0 2 4 5 >>
c'gtk_label_set_line_wrap (c'GTK_LABEL w) c'TRUE >>
c'gtk_label_set_justify (c'GTK_LABEL w) c'GTK_JUSTIFY_CENTER >>
c'gtk_widget_show w
-- These are widgets whose values we'll change.
choice1 <- c'gtk_label_new nullPtr >>= \w -> tableAttach w 0 2 0 1 >> return w
choice2 <- c'gtk_label_new nullPtr >>= \w -> tableAttach w 0 2 1 2 >> return w
currentWord <- c'gtk_label_new nullPtr >>= \w -> tableAttach w 1 2 2 3 >> return w
fullText <- c'gtk_label_new nullPtr >>= \w -> tableAttach w 1 2 3 4 >> return w
mapM_ (flip c'gtk_label_set_ellipsize c'PANGO_ELLIPSIZE_MIDDLE) $
map c'GTK_LABEL [choice1,choice2,currentWord]
mapM_ c'gtk_widget_show [choice1,choice2,currentWord,fullText,window]
c'gtk_label_set_line_wrap (c'GTK_LABEL fullText) c'TRUE
c'gtk_label_set_justify (c'GTK_LABEL fullText) c'GTK_JUSTIFY_FILL
-- This function will update widgets to reflect
-- current program state, obtained from IO functions
-- provided in doGui call.
dataToWindow <- return $ do
(s1,s2) <- getChoices
let toLabel = (flip withCString . c'gtk_label_set_markup . c'GTK_LABEL)
toLabel choice1 $ choiceStyle s1
toLabel choice2 $ choiceStyle s2
toLabel currentWord =<< liftM wordStyle getCurrentWord
toLabel fullText =<< liftM textStyle getFullText
-- A callback to answer key presses, identified by
-- GDK codes.
keyAction <- return $ \k -> do
when (k == c'GDK_e) $ setCorpus englishCorpus
when (k == c'GDK_p) $ setCorpus portugueseCorpus
when (k == c'GDK_q) c'gtk_main_quit
when (k == c'GDK_1) $ setChoice $ Left ()
when (k == c'GDK_2) $ setChoice $ Right ()
dataToWindow
-- Code gluing key presses received by the main
-- window to the callback. If you want to understand it
-- you need to know about GTK+ accelerator groups and
-- GObject closures:
--
-- http://library.gnome.org/devel/gtk/stable/gtk-Keyboard-Accelerators.html
-- http://library.gnome.org/devel/gobject/stable/gobject-Closures.html
c'gtk_accel_group_new >>= \w -> do
c'gtk_window_add_accel_group (c'GTK_WINDOW window) (c'GTK_ACCEL_GROUP w)
let registerClosure k c = c'gtk_accel_group_connect (c'GTK_ACCEL_GROUP w) k 0 0 c
let keys = [c'GDK_1,c'GDK_2,c'GDK_e,c'GDK_p,c'GDK_q]
callback <- return $ \_ _ key _ -> keyAction key >> return c'TRUE
callbackC <- mk'GtkAccelGroupActivate callback
closures <- sequence $ replicate (length keys) $ c'g_cclosure_new
(c'G_CALLBACK callbackC) nullPtr nullFunPtr
zipWithM_ registerClosure keys closures
-- Provide an initial corpus, update widgets and
-- enter main GUI loop.
setCorpus englishCorpus
dataToWindow
c'gtk_main