First attempt at using GTK with haskell.

Having managed to connect to a mysql database, the next step I wanted to try is display the result in a graphical window.

I would have loved to find QT bindings for haskell, but it seems that doesn't exist.
So, the choices for a GUI are limited to wxHaskell and Gtk2hs. There are other GUI libraries but they're higher level and I didn't want to begin with something maybe too hard. I choose Gtk2hs.

I downloaded, compiled and installed Gtk2hs without trouble and my first program is an exact replica of the glade tutorial.

After that, I modified the window to add a 4th part to the vbox, made a few modifications and added a treeview :











Now I wanted to be able to add my own data to the list.

I had a look at ListDemo.hs from Gtk2hs' examples, but it creates its own treeview, while I get mine from the XML file glade creates.

I tried reading the docs to find the relevant functions but it's not that well explained. Fortunately, ListTest.hs uses a xml file from glade.

From the example, this is the part that manipulate the treeview :

import Graphics.UI.Gtk
import Graphics.UI.Gtk.Glade
import Graphics.UI.Gtk.ModelView as New

data Phone = Phone { name :: String, number :: Int, marked :: Bool }

main = do

...

view <- xmlGetWidget xml castToTreeView "view"

...

-- create a new list store
store <- storeImpl
New.treeViewSetModel view store
setupView view store

...

setupView view model = do
New.treeViewSetHeadersVisible view True

-- add a couple columns
renderer1 <- New.cellRendererTextNew
col1 <- New.treeViewColumnNew
New.treeViewColumnPackStart col1 renderer1 True
New.cellLayoutSetAttributes col1 renderer1 model $ \row -> [ New.cellText := name row ]
New.treeViewColumnSetTitle col1 "String column"
New.treeViewAppendColumn view col1

...

storeImpl =
New.listStoreNew
 [Phone { name = "Foo", number = 12345, marked = False }
 ,Phone { name = "Bar", number = 67890, marked = True  }
 ,Phone { name = "Baz", number = 39496, marked = False }]

The thing I want, though, is feed it the result of a sql query. The result is a list of rows, each row itself being a list of strings. The first row has the column titles.

The storeImpl funtion needs to change to (dbresult being the result from the database)
storeImpl = New.listStoreNew ( tail dbresult )

Now to display this I have to change the setupView function; it has to take an arbitrary list of columns. If you look at the ListTest example, you see that now many things change between the different column creation : the title, and how to get the column's content from a row.

This is how I did it :

setupView view model cols= do
New.treeViewSetHeadersVisible view True

mapM ( \(num,title) -> newcol view model title $ \row -> [ New.cellText := row !! num ] ) $ zip [0..] cols
where
 newcol view model title content = do
   renderer <- New.cellRendererTextNew
   col <- New.treeViewColumnNew
   New.treeViewColumnPackStart col renderer True
   New.cellLayoutSetAttributes col renderer model $ content
   New.treeViewColumnSetTitle col title
   New.treeViewAppendColumn view col

The newcol function creates a new column based on the title and how to get the content from the liststore, to create all the columns I map newcol through the list of numbered columns.

And it works !

Here's the full source of the example, some stuff from the glade tutorial is still left over and there are still some French comments, but it works here :)

import Prelude
import IO hiding (bracket)
import Control.Exception

import Database.HSQL as Hsql
import Database.HSQL.MySQL as Hsql

import Graphics.UI.Gtk
import Graphics.UI.Gtk.Glade
import Graphics.UI.Gtk.ModelView as New

data Phone = Phone { name :: String, number :: Int, marked :: Bool }

main = do
initGUI
Just xml <- xmlNew "hellohaskell.glade"
--
-- Réagir à la fermeture de la fenetre
--
window <- xmlGetWidget xml castToWindow "window1"
onDestroy window mainQuit
--
-- Réagir au clic sur bouton fermer
--
clbutton <- xmlGetWidget xml castToButton "button2"
onClicked clbutton $ do
  putStrLn "Close Button Clicked"
onClicked clbutton $ do
  widgetDestroy window
--
-- Réagir au clic sur bouton ok
--
prompt   <- xmlGetWidget xml castToLabel "label1"
txtfield <- xmlGetWidget xml castToEntry "entry1"
okbutton <- xmlGetWidget xml castToButton "button1"
onClicked okbutton $ do
  name <- get txtfield entryText
  set prompt [ labelText := "Hello " ++ name ]

onEntryActivate txtfield $ do
  name <- get txtfield entryText
  set prompt [ labelText := "Hello " ++ name ]
--
-- Mettre des lignes dans le listview
--
recupbase <- testdb
view <- xmlGetWidget xml castToTreeView "treeview1"
store <- New.listStoreNew ( tail recupbase )
New.treeViewSetModel view store
setupView view store (head recupbase)

--
-- Lancer le tout
--
mainGUI


setupView view model cols= do
New.treeViewSetHeadersVisible view True

mapM ( \(num,title) -> newcol view model title $ \row -> [ New.cellText := row !! num ] ) $ zip [0..] cols

-- add a couple columns
where
  newcol view model title content = do
    renderer <- New.cellRendererTextNew
    col <- New.treeViewColumnNew
    New.treeViewColumnPackStart col renderer True
    New.cellLayoutSetAttributes col renderer model $ content
    New.treeViewColumnSetTitle col title
    New.treeViewAppendColumn view col

-- The part where I handle the SQL query

db_serv    = "127.0.0.1"
db_shema   = "test"
db_user    = "root"
db_pass    = ""

sql = "SELECT * FROM adr ORDER BY num"

testdb = withdb db_serv db_shema db_user db_pass (dbquery sql recupRows)

withdb serv shema user pass func =
bracket (Hsql.connect serv shema user pass >>= ( \cnx -> putStrLn "Connected" >> return cnx))
        (\cnx -> Hsql.disconnect cnx >> putStrLn "Disconnected")
        (\cnx -> func cnx)

dbquery sql func cnx=
bracket (Hsql.query cnx sql >>= ( \stmt -> putStrLn ( "Ran query " ++ sql ) >> return stmt))
        (\stmt -> Hsql.closeStatement stmt >> putStrLn "Closed query")
        (\stmt -> func stmt)

recupRows :: Statement -> IO [[String]]
recupRows stmt = do
let champs = map (\(a,b,c) -> a) $ getFieldsTypes stmt
lignes <- collectRows (\s -> mapM (getFieldValue s) champs ) stmt
return ( champs : lignes )