Ticket #1251: Leak.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE RankNTypes, KindSignatures #-}

module Main where

import Graphics.UI.Gtk
import Data.IORef
import System.Random

main :: IO ()
main = do
    _msgs <- initGUI
    window <- windowNew
    set window [containerBorderWidth := 10]
    listRef <- newIORef Nothing
    buildButton <- buttonNewWithLabel "Build List"
    vbox <- vBoxNew False 0
    _ <- onClicked buildButton $ do
        maybeList <- readIORef listRef
        case maybeList of
            Nothing -> return ()
            Just (prevTview, prevListStore) -> do
                -- Uncomment the following line to stop leaking memory.
                --listStoreClear prevListStore
                widgetDestroy prevTview
        (newTview, newListStore) <- makeListView
        writeIORef listRef (Just (newTview, newListStore))
        boxPackEnd vbox newTview PackGrow 0
        widgetShowAll newTview
    boxPackStart vbox buildButton PackNatural 0
    containerAdd window vbox
    widgetShowAll window
    mainGUI

makeListView :: IO (TreeView, ListStore String)
makeListView = do
    lstore <- listStoreNew []
    tview <- treeViewNewWithModel lstore
    treeViewSetHeadersVisible tview True
    stringColumn tview lstore "Stuff" id

    let addRow i = do
            n <- randomIO :: IO Int
            listStoreAppend lstore (show i ++ ": " ++ show n)

    mapM_ addRow [0..10000 :: Int]

    return (tview, lstore)

stringColumn :: forall (model :: * -> *) row self.
                (TreeViewClass self,
                TreeModelClass (model row),
                TypedTreeModelClass model)
             => self -> model row -> String -> (row -> String) -> IO ()
stringColumn tview lst title fn = do
    tcol <- treeViewColumnNew
    tcell <- cellRendererTextNew
    treeViewColumnSetTitle tcol title
    treeViewColumnPackStart tcol tcell False
    cellLayoutSetAttributes tcol tcell lst $
        \x -> [cellText := fn x]
    _ <- treeViewAppendColumn tview tcol
    return ()