[Gtk2hs-commit] (main branch): Add another demo that uses callbacks. This was mainly to test if -threaded now works.

[Axel S. <si...@co...>]

Sun Nov 22 14:29:20 EST 2009  Axel Simon <Axe...@en...>
  * Add another demo that uses callbacks. This was mainly to test if -threaded now works.

    addfile ./demo/treeList/ListText.hs
    hunk ./demo/treeList/ListText.hs 1
    +import Graphics.UI.Gtk
    +import Data.Char
    +import Data.List
    +import Data.Maybe
    +
    +data RowInfo = RowInfo { rowString :: String, rowCase :: Maybe Bool }
    +
    +mkCase Nothing str = str
    +mkCase (Just False) str = map toLower str
    +mkCase (Just True) str = map toUpper str
    +
    +advCase Nothing = Just False
    +advCase (Just False) = Just True
    +advCase (Just True) = Nothing
    +
    +main :: IO ()
    +main = do
    +  unsafeInitGUIForThreadedRTS
    +  win <- windowNew
    +  win `on` objectDestroy $ mainQuit
    +
    +  content <- readFile "ListText.hs"
    +
    +  model <- listStoreNew (map (\r -> RowInfo r Nothing) (lines content))
    +  view <- treeViewNewWithModel model
    +
    +  -- add a column showing the index
    +  col <- treeViewColumnNew
    +  treeViewAppendColumn view col
    +
    +  cell <- cellRendererTextNew
    +  cellLayoutPackStart col cell True
    +  cellLayoutSetAttributeFunc col cell model $ \(TreeIter _ n _ _) ->
    +    set cell [cellText := show n]
    +  set col [treeViewColumnTitle := "line",
    +	   treeViewColumnReorderable := True ]
    +
    +  -- add a column showing the line in the file
    +  col <- treeViewColumnNew
    +  treeViewAppendColumn view col
    +  set col [treeViewColumnTitle := "line in file",
    +	   treeViewColumnReorderable := True ]
    +
    +  cell <- cellRendererTextNew
    +  cellLayoutPackStart col cell True
    +  cellLayoutSetAttributes col cell model $
    +    \row -> [cellText := mkCase (rowCase row) (rowString row)]
    +  [_$_]
    +  -- add a column showing if it is forced to a specific case
    +  col <- treeViewColumnNew
    +  treeViewAppendColumn view col
    +  set col [treeViewColumnTitle := "case",
    +	   treeViewColumnReorderable := True ]
    +
    +  cell <- cellRendererToggleNew
    +  cellLayoutPackStart col cell True
    +  cellLayoutSetAttributes col cell model $
    +    \row -> [cellToggleActive := fromMaybe False (rowCase row),
    +	     cellToggleInconsistent := rowCase row==Nothing]
    +  cell `on` cellToggled $ \tpStr -> do
    +    let [i] = stringToTreePath tpStr
    +    row@RowInfo { rowCase = c } <- listStoreGetValue model i
    +    listStoreSetValue model i row { rowCase = advCase c }
    +
    +  -- to annoy the user: don't allow any columns to be dropped at the far right
    +  treeViewSetColumnDragFunction view $ Just $ \_ rCol _ -> do
    +    putStrLn ("querying reorderability")
    +    return (rCol /= Nothing)
    +
    +  view `on` cursorChanged $ do
    +    putStrLn "Cursor changed"
    +    mapM_ (const windowNew) [0..10]
    +
    +
    +  treeViewSetSearchEqualFunc view $ Just $ \str (TreeIter _ n _ _) -> do
    +    row <- listStoreGetValue model (fromIntegral n)
    +    return (map toLower str `isPrefixOf` map toLower (filter isAlphaNum (rowString row)))
    +
    +  swin <- scrolledWindowNew Nothing Nothing
    +  set swin [ containerChild := view ]
    +  set win [ containerChild := swin ]
    +  widgetShowAll win
    +  mainGUI
    +
    hunk ./demo/treeList/Makefile 3
    -	 listdnd filterdemo
    +	 listdnd filterdemo listtext
    hunk ./demo/treeList/Makefile 6
    -	TreeSort.hs Completion.hs ListDND.hs FilterDemo.hs
    +	TreeSort.hs Completion.hs ListDND.hs FilterDemo.hs ListText.hs
    hunk ./demo/treeList/Makefile 36
    +
    +listtext : ListText.hs
    +	$(HC_RULE)