Haskell gtk combobox

Haskell_gtk2hs_combobox.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}

import Data.String
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Gdk.GC
import qualified Data.Tree as Tree
import qualified Data.Text as T


data ListElement = ListElement { leName :: String   ,   selected::String  }

main :: IO ()   
main = do    
    initGUI
    window  <- windowNew

    comboBox <- comboBoxNew
    comboBox1 <- comboBoxNew
       
    comboBoxSetModelText comboBox
    comboBoxAppendText comboBox ("white"::T.Text)
    comboBoxAppendText comboBox ("red"::T.Text)
    comboBoxAppendText comboBox ("green"::T.Text)
    comboBoxAppendText comboBox ("yellow"::T.Text)
    comboBoxAppendText comboBox ("blue"::T.Text)
    
    fixed <- fixedNew
   
    fixedPut fixed comboBox (10,90)
    fixedPut fixed comboBox1 (110,90)    
   
    on comboBox changed $ do
         selIdx <-  comboBoxGetActive comboBox
         let str = getLst !! selIdx
         putStrLn ((show selIdx)++" "++(T.unpack str))

    widgetSetSizeRequest  comboBox 80 35
    widgetSetSizeRequest  comboBox1 150 35
    setupComboBox comboBox1 getLst
   
    manListStore::(ListStore String) <-  listStoreNew manufacturers

    let elements = [ (ListElement "joe"  " ")  , (ListElement "bob"  " ") ]

    listStore::(ListStore ListElement) <- listStoreNew elements
    treeview <- treeViewNewWithModel listStore :: IO TreeView 
    treeViewSetHeadersVisible treeview True
    nameCol <- treeViewColumnNew
    comboCol <- treeViewColumnNew

    treeViewColumnSetTitle nameCol ("name"::String)
    treeViewColumnSetTitle comboCol ("combo"::String)  
    nameRenderer <- cellRendererTextNew
    comboRenderer <- cellRendererComboNew

    cellLayoutPackStart nameCol nameRenderer True
    cellLayoutPackStart comboCol comboRenderer True
    treeViewAppendColumn treeview nameCol
    treeViewAppendColumn treeview comboCol

    cellLayoutSetAttributes nameCol nameRenderer listStore $
      \x -> [cellText := leName x ]

{-
    cellLayoutSetAttributes comboCol comboRenderer listStore $ \x ->        
      [ cellTextEditable := True
      , cellComboTextModel := (leListStore x, makeColumnIdString 0 :: ColumnId String String)      
      , cellComboHasEntry := False
      , cellText := (selected x)
      ]
      -}

    cellLayoutSetAttributeFunc comboCol comboRenderer listStore $ 
        (\iter -> do (tmodel, colid) <- comboTextModel 
                     (ListElement a b) <- treeModelGetRow listStore iter
                     set comboRenderer [ cellVisible        := True
                                       , cellComboTextModel := (tmodel, colid)
                                       , cellTextEditable   := True
                                       , cellComboHasEntry  := False
                                       , cellText           := b])  


  -- here is where we will set the combo options!!!!
    _ <- on comboRenderer editingStarted $ \widget treepath -> do
     case treepath of
      [k] -> do
        listElement <- listStoreGetValue listStore k
        comboListStore <- comboBoxSetModelText (castToComboBox widget)
        mapM_ (listStoreAppend comboListStore . T.pack) manufacturers
      ks -> error $ "bad treepath for liststore: " ++ show ks      

  -- an action when the combo box is edited
    _ <- on comboRenderer edited $ \_treePath newVal -> do
        case _treePath of
          [k] -> do
           (ListElement a b) <- listStoreGetValue listStore k
           let toStore = ListElement a newVal
           listStoreSetValue listStore k toStore
           putStrLn $ "combo box edited, new value: " ++ newVal

    fixedPut fixed treeview (10,150)
    widgetSetSizeRequest  treeview 500 300
    containerAdd window fixed
    onDestroy window mainQuit
    windowSetDefaultSize window 800 600
    windowSetPosition window WinPosCenter
    widgetShowAll window
    mainGUI

getLst = [("Sony"::T.Text), ("LG"::T.Text), ("Panasonic"::T.Text), ("Toshiba"::T.Text), ("Nokia"::T.Text), ("Samsung"::T.Text)]
manufacturers = [("Sony"::String), ("LG"::String), ("Panasonic"::String), ("Toshiba"::String), ("Nokia"::String), ("Samsung"::String)]

comboTextModel = do store <- listStoreNew []
                    let column = makeColumnIdString 0 :: ColumnId String String
                    return (store, column)

setupComboBox :: ComboBox ->[T.Text]-> IO ()
setupComboBox comboBox lst =  do
    cellLayoutClear comboBox
    store::(ListStore T.Text) <- listStoreNew([]::[ T.Text])
    comboBoxSetModel comboBox (Just store)
    setupListStore store  lst   -- must not precede the comboBoxSetModel statement  
    let colId = (makeColumnIdString 0 :: ColumnId T.Text T.Text)
    customStoreSetColumn store colId id
    comboBoxSetEntryTextColumn comboBox colId
    ren <- cellRendererTextNew
    fnt <- fontDescriptionNew
    fontDescriptionSetFamily fnt ("Serif"::String)
    fontDescriptionSetWeight fnt WeightBold
    fontDescriptionSetSize fnt 14
    set ren [cellTextFontDesc := fnt] 
    cellLayoutPackStart  comboBox ren True
    cellLayoutSetAttributes comboBox ren store setAttributesOfRenderer
    comboBoxSetActive comboBox 0
    widgetSetSizeRequest comboBox (-1) 38

setupListStore :: (ListStore T.Text) -> [T.Text]-> IO ()
setupListStore store lst =  do
    mapM_ (\x -> listStoreAppend store x) lst 
    return ()    

setAttributesOfRenderer :: T.Text -> [AttrOp CellRendererText]
setAttributesOfRenderer a =
  [cellText := a]