Ticket #1251: Leak.hs

File Leak.hs, 1.9 kB (added by guest, 2 years ago)

Demonstration of the leak

Line 
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE RankNTypes, KindSignatures #-}
3
4module Main where
5
6import Graphics.UI.Gtk
7import Data.IORef
8import System.Random
9
10main :: IO ()
11main = do
12    _msgs <- initGUI
13    window <- windowNew
14    set window [containerBorderWidth := 10]
15    listRef <- newIORef Nothing
16    buildButton <- buttonNewWithLabel "Build List"
17    vbox <- vBoxNew False 0
18    _ <- onClicked buildButton $ do
19        maybeList <- readIORef listRef
20        case maybeList of
21            Nothing -> return ()
22            Just (prevTview, prevListStore) -> do
23                -- Uncomment the following line to stop leaking memory.
24                --listStoreClear prevListStore
25                widgetDestroy prevTview
26        (newTview, newListStore) <- makeListView
27        writeIORef listRef (Just (newTview, newListStore))
28        boxPackEnd vbox newTview PackGrow 0
29        widgetShowAll newTview
30    boxPackStart vbox buildButton PackNatural 0
31    containerAdd window vbox
32    widgetShowAll window
33    mainGUI
34
35makeListView :: IO (TreeView, ListStore String)
36makeListView = do
37    lstore <- listStoreNew []
38    tview <- treeViewNewWithModel lstore
39    treeViewSetHeadersVisible tview True
40    stringColumn tview lstore "Stuff" id
41
42    let addRow i = do
43            n <- randomIO :: IO Int
44            listStoreAppend lstore (show i ++ ": " ++ show n)
45
46    mapM_ addRow [0..10000 :: Int]
47
48    return (tview, lstore)
49
50stringColumn :: forall (model :: * -> *) row self.
51                (TreeViewClass self,
52                TreeModelClass (model row),
53                TypedTreeModelClass model)
54             => self -> model row -> String -> (row -> String) -> IO ()
55stringColumn tview lst title fn = do
56    tcol <- treeViewColumnNew
57    tcell <- cellRendererTextNew
58    treeViewColumnSetTitle tcol title
59    treeViewColumnPackStart tcol tcell False
60    cellLayoutSetAttributes tcol tcell lst $
61        \x -> [cellText := fn x]
62    _ <- treeViewAppendColumn tview tcol
63    return ()