bitspeak-0.0.2: src/Gui.hs

{-

  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 = ("<big><big><big><big><tt>" ++) . (++ "</tt></big></big></big></big>")
wordStyle = ("<big><big><big><big><i>" ++) . (++ "</i></big></big></big></big>")
textStyle = ("<big><big><big><b>" ++) . (++ "</b></big></big></big>")
labelStyle = ("<big>" ++) . (++ "</big>")
infoStyle = ("<big><i>" ++) . (++ "</i></big>")

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