Playing with Gtk in Haskell (gtk2hs), making my TreeView widget filterable

Haskell_gtk2hs_filtering_treeview.hs

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

import Data.IORef
import Graphics.UI.Gtk
import Graphics.UI.Gtk.ModelView
import qualified Data.Text as T
import Graphics.UI.Gtk.Gdk.Events as Ev
import Data.Maybe
import System.IO.Unsafe

{-# NOINLINE myFilter #-}
myFilter :: IORef String
myFilter = unsafePerformIO (newIORef "0")

data RegularSoft = RegularSoft {title:: T.Text,year:: Int,author:: T.Text}

main = do
  initGUI

  win <- windowNew
  on win objectDestroy mainQuit

  set win [ windowTitle         := ("TreeView test"::T.Text)
             , windowResizable    := True
             , windowDefaultWidth  := 630
             , windowDefaultHeight := 450 ]
  
  grid <- tableNew 2 1 True
  scrollable_treelist <- scrolledWindowNew  Nothing Nothing
  scrolledWindowSetPolicy scrollable_treelist PolicyAutomatic PolicyAutomatic
  
  let grLines = TreeViewGridLinesBoth
  
  listModel <- listStoreNew  getBooks
  filtered	<- treeModelFilterNew listModel []

  view <- treeViewNewWithModel filtered
  
  treeViewSetHeadersVisible view True
  treeViewSetGridLines view grLines
  
  setTreeView view filtered listModel
 
  columns <- treeViewGetColumns view
  mapM (\x-> treeViewColumnSetResizable x True) columns
  
  btJav  <- buttonNewWithLabel ("Java"::String)
  btC  <- buttonNewWithLabel ("C"::String)
  btCpp  <- buttonNewWithLabel ("C++"::String)
  btPy  <- buttonNewWithLabel ("Python"::String)
  btNon  <- buttonNewWithLabel ("None"::String)
  row  <- hBoxNew False 5
  containerAdd row btJav  
  containerAdd row btC  
  containerAdd row btCpp  
  containerAdd row btPy  
  containerAdd row btNon
  containerAdd scrollable_treelist view

  onClicked btJav   $ buttonOnClicked btJav  filtered listModel
  onClicked btC   $ buttonOnClicked btC  filtered listModel
  onClicked btCpp   $ buttonOnClicked btCpp  filtered listModel
  onClicked btPy   $ buttonOnClicked btPy  filtered listModel
  onClicked btNon   $ buttonOnClicked btNon  filtered listModel

  tableAttach grid scrollable_treelist 0 1 0 1 [Fill] [Fill] 5 5 
  tableAttach grid row 0 1 1 2 [Expand] [Expand] 0 0

  let filterFunc = (\iter -> do                   
                   (RegularSoft n b m) <- treeModelGetRow  listModel iter
                   strF <- readIORef  myFilter
                   let mm = T.unpack m
                   case strF of
                      "0" -> return True
                      _ -> if (mm==strF) then return True else return False)
  
  treeModelFilterSetVisibleFunc filtered filterFunc
  containerAdd win grid
  widgetShowAll win
  mainGUI  
      
getBooks::[RegularSoft]
getBooks = [(RegularSoft ("Firefox"::T.Text) 2002 ("C++"::T.Text)), (RegularSoft ("Eclipse"::T.Text) 2004 ("Java"::T.Text)),
  (RegularSoft ("Pitivi"::T.Text) 2004 ("Python"::T.Text)), (RegularSoft ("Netbeans"::T.Text) 1996 ("Java"::T.Text)),
  (RegularSoft ("Chrome"::T.Text) 2008 ("C++"::T.Text)), (RegularSoft ("Filezilla"::T.Text) 2001 ("C++"::T.Text)),
  (RegularSoft ("Bazaar"::T.Text) 2005 ("Python"::T.Text)), (RegularSoft ("Git"::T.Text) 2005 ("C"::T.Text)),
  (RegularSoft ("Linux Kernel"::T.Text) 1991 ("C"::T.Text)), (RegularSoft ("GCC"::T.Text) 1987 ("C"::T.Text)),
  (RegularSoft ("Frostwire"::T.Text) 2004 ("Java"::T.Text))]      

buttonOnClicked::Button ->(TypedTreeModelFilter RegularSoft)->(ListStore RegularSoft)-> IO()
buttonOnClicked bt ttf listModel= do     
     strLabel <- buttonGetLabel bt
     let j = ("Java"::T.Text) ; p = ("Python"::T.Text); cpp = ("C++"::T.Text); c = ("C"::T.Text)
     let lang = case strLabel of
                   ("Java"::String) -> strLabel
                   ("Python"::String) -> strLabel
                   ("C++"::String) -> strLabel
                   ("C"::String) -> strLabel
                   _ -> ("0"::String)
         
     writeIORef myFilter lang            
     treeModelFilterRefilter  ttf               
     putStrLn strLabel

setTreeView::TreeView->(TypedTreeModelFilter RegularSoft)->(ListStore RegularSoft)->IO()
setTreeView tv filteredModel listModel= do
  treeViewSetHeadersVisible tv True

  col1 <- treeViewColumnNew
  col2 <- treeViewColumnNew
  col3 <- treeViewColumnNew

  treeViewColumnSetTitle col1 ("String column"::T.Text  )
  treeViewColumnSetTitle col2 ("Int column"::T.Text  )
  treeViewColumnSetTitle col3 ("String column"::T.Text  )

  renderer1 <- cellRendererTextNew
  renderer2 <- cellRendererTextNew
  renderer3 <- cellRendererTextNew

  cellLayoutPackStart col1 renderer1 True
  cellLayoutPackStart col2 renderer2 True
  cellLayoutPackStart col3 renderer3 True

  cellLayoutSetAttributeFunc col1 renderer1 filteredModel $ \iter -> do
   cIter <- treeModelFilterConvertIterToChildIter filteredModel iter
   (RegularSoft n b m) <- treeModelGetRow listModel cIter
   set renderer1 [cellText := n]
   
  cellLayoutSetAttributeFunc col2 renderer2 filteredModel $ \iter -> do
   cIter <- treeModelFilterConvertIterToChildIter filteredModel iter
   (RegularSoft n b m) <- treeModelGetRow listModel cIter
   set renderer2 [cellText := (show b)]
   
  cellLayoutSetAttributeFunc col3 renderer3 filteredModel $ \iter -> do
   cIter <- treeModelFilterConvertIterToChildIter filteredModel iter
   (RegularSoft n b m) <- treeModelGetRow listModel cIter
   set renderer3 [cellText := m]

  treeViewAppendColumn tv col1
  treeViewAppendColumn tv col2
  treeViewAppendColumn tv col3
  return ()