module Main where import Graphics.UI.WX import Graphics.UI.WXCore hiding (Event) main :: IO () main = start hello hello :: IO () hello = do -- the application frame f <- frame [text := "Simple Db", clientSize := sz 600 400] p <- panel f [] s <- splitterWindow p [] --may need to use mutable variable store values which are likely to change during program execution currentDb <- varCreate "Null" tablesInDatabase <- varCreate [] databaseView <- treeCtrl s [text := "Trial",visible:= True] top <- treeCtrlAddRoot databaseView "System" 0 0 objectNull g <- gridCtrl s [] -- create file menu file <- menuPane [text := "&File"] open <- menuItem file [text := "Open..",help := "Open Database"] save <- menuItem file [text := "Save", help := "Write Table data to file"] closeMenuItem <- menuItem file [text := "Close" , help := "Close database and all tabled contained in it"] quit <- menuQuit file [help := "Quit the demo", on command := close f] --create tool menu tools <- menuPane [text :="&Tools"] createdb <- menuItem tools [text:="Create Database", help := "Create database dir"] --create Table menu table <- menuPane [text := "T&able"] newTable <- menuItem table [text:="New..",help := "Creates a new table in the current database",on command := enterColumnNames p ] openTableMI <- menuItem table [text := "Open",help := "Opens a table present in the currently opend data base", on command := do filename<- fileOpenDialog p True True "Open Table" [("Any file",["*.*"])] "" "" case filename of Just name -> infoDialog p "Not yet implemented" "Please add code to for functionality" Nothing -> return () ] addRow <- menuItem table [text := "Add Row", help := "Adds a new row (at bottom) to table",on command := infoDialog p "Not yet implemented" "Please add code to for functionality"] deleteRow <- menuItem table [text := "Delete Row",help := "Deletes selected row(s) from table" ,on command := infoDialog p "Not yet implemented" "Please add code to for functionality"] -- create Help menu hlp <- menuHelp [] about <- menuAbout hlp [help := "About wxHaskell"] -- create statusbar field status <- statusField [text := "Welcome to wxHaskell"] -- create Toolbar tbar <- toolBar f [] createdbTB <-toolMenu tbar createdb "Create Database" "" [] openTableTB <-toolMenu tbar openTableMI "Open Table" "" [] newTableTB <-toolMenu tbar newTable "Create Table" "" [] addRowTB <-toolMenu tbar addRow "Add" "" [] deleteRowTB <-toolMenu tbar deleteRow "Delete" "" [] saveTB <-toolMenu tbar save "Save" "" [] loadTableInGrid g cols list windowOnKeyDown g (onGridKeyDown g) set g [on gridEvent := onGrid g ] -- set the statusbar and menubar set f [layout := container p $ margin 5 $ fill $ vsplit s 5 {- sash width -} 160 {- left pane width -} (widget databaseView) (widget g) ,statusBar := [status] , menuBar := [file,table,tools,hlp] ,clientSize := sz 800 600 ] set createdb [on command := do infoDialog p "Not yet implemented" "Please add code to for functionality"] set open [on command := do infoDialog p "Not yet implemented" "Please add code to for functionality"] set save [on command := do infoDialog p "Not yet implemented" "Please add code to for functionality"] where onGridKeyDown g (EventKey key mods pt) = case key of KeyReturn -> do logMessage "keyEnter" gridMoveNext g _ -> propagateEvent onGrid g ev = case ev of GridCellChange row col veto -> do currentChange <- gridGetCellValue g row col logMessage ("cell changed: " ++ show (row,col,currentChange) ) _ -> propagateEvent setRow g (row,values) = mapM_ (\(col,value) -> gridSetCellValue g row col value) (zip [0..] values) {-------------------------------------------------------------------------------- Library? --------------------------------------------------------------------------------} gridCtrl :: Window a -> [Prop (Grid ())] -> IO (Grid ()) gridCtrl parent props = feed2 props 0 $ initialWindow $ \id rect -> \props flags -> do g <- gridCreate parent id rect flags gridCreateGrid g 0 0 0 set g props return g gridEvent :: Event (Grid a) (EventGrid -> IO ()) gridEvent = newEvent "gridEvent" gridGetOnGridEvent gridOnGridEvent gridMoveNext :: Grid a -> IO () gridMoveNext g = do row <- gridGetGridCursorRow g col <- gridGetGridCursorCol g rowCount <- gridGetNumberRows g colCount <- gridGetNumberCols g let (r,c) = if (row+1 >= rowCount) then if (col+1 >= colCount) then (0,0) else (0,col+1) else (row+1,col) gridSetGridCursor g r c gridMakeCellVisible g r c return () appendColumns :: Grid a -> [String] -> IO () appendColumns g [] = return () appendColumns g labels = do n <- gridGetNumberCols g gridAppendCols g (length labels) True mapM_ (\(i,label) -> gridSetColLabelValue g i label) (zip [n..] labels) appendRows :: Grid a -> [String] -> IO () appendRows g [] = return () appendRows g labels = do n <- gridGetNumberRows g gridAppendRows g (length labels) True mapM_ (\(i,label) -> gridSetRowLabelValue g i label) (zip [n..] labels) loadTableInGrid :: Grid ()-> [String] ->[[String]] -> IO() loadTableInGrid grid columnNames tableData = do gridSetGridLineColour grid (colorSystem Color3DFace) gridClearGrid grid appendColumns grid columnNames appendRows grid (map show [1..(length tableData)]) mapM_ (setRow grid) (zip [0..] tableData) gridAutoSize grid return () list::[[String]] list = replicate 10 (replicate 5 "") cols :: [String] cols = ["Column1","Column2","Column3","Column4","Column5"] enterColumnNames parent = do frm <- dialog parent [text := "Enter Column Names", clientSize := sz 300 600, resizeable := True,visible:=True] columnNames <- varCreate [] g <- gridCtrl frm [] ok <- button frm [text :="OK"] loadTableInGrid g ["Column Name"](replicate 10 [""]) set frm [layout := column 5 [fill (dynamic (widget g)) ,hfill $ minsize (sz 20 80) $ widget ok] ] showModal frm (\stop -> set ok[ on command :=do colNames g columnNames result <- varGet columnNames let cols = [x|x<-result,x/=""] varSet columnNames cols stop(Just True)]) return() where colNames grid changes = do result <- mapM (\row-> gridGetCellValue grid row 0) [0..9] return ()