Grid.hs

module View.Component.Grid (Grid,new,getCursorPos
                           ,cycleCursor
                           ,setValue,getValue
                           ,getRowValues,getColumnValues
                           ,getRowLabel,getColumnLabel
                           ,getRowLabels,getColumnLabels
                           ,setRowLabel,setColumnLabel
                           ,addRows,addColumns
                           ,insertRowBefore,insertColumnBefore
                           ,numDataRows,numDataColumns
                           ,deleteColumns,deleteRows
                           )
    where

import Control.Exception (assert)
import Control.Monad (forM,forM_)
import Control.Applicative ((<$>))
import qualified Graphics.UI.WX as WX
import qualified Graphics.UI.WXCore as WXC
import Data.List (sort)
import CellCoordinate (CellCoord)
import Util (deleteByIndices)

type Grid = WXC.Grid ()

new :: WX.Window a -> [WX.Prop Grid] -> IO Grid
new parent props =
    let createFromParent id rect props flags = 
            do g <- WXC.gridCreate parent id rect flags
               WXC.gridCreateGrid g 0 0 0
               WX.set g props
               return g
    in do
      grid <- WX.initialWindow createFromParent props 0
      WXC.gridAppendRows grid 1 True
      WXC.gridAppendCols grid 1 True
      WXC.gridSetRowLabelValue grid 0 "..."
      WXC.gridSetColLabelValue grid 0 "..."
      return grid

cycleCursor :: Grid -> IO ()
cycleCursor grid = do 
  (row,col) <- getCursorPos grid
  rowCount <- WXC.gridGetNumberRows grid
  colCount <- WXC.gridGetNumberCols grid
  let (row',col') = 
          if row+1 >= rowCount 
          then if col+1 >= colCount then (0,0) else (0,col+1)
          else (row+1,col)
  WXC.gridSetGridCursor grid row' col'

getCursorPos :: Grid -> IO CellCoord
getCursorPos grid = do
  row <- WXC.gridGetGridCursorRow grid
  col <- WXC.gridGetGridCursorCol grid
  return (row,col)
    
getValue :: CellCoord -> Grid -> IO String
getValue (row,col) grid = WXC.gridGetCellValue grid row col

setValue :: CellCoord -> String -> Grid -> IO ()
setValue (row,col) s grid = WXC.gridSetCellValue grid row col s

numDataRows,numDataColumns :: Grid -> IO Int
numDataRows grid = WXC.gridGetNumberRows grid >>= \n -> return $ n-1
numDataColumns grid = WXC.gridGetNumberCols grid >>= \n -> return $ n-1

getRowLabel,getColumnLabel :: Int -> Grid -> IO String
getRowLabel = flip WXC.gridGetRowLabelValue
getColumnLabel = flip WXC.gridGetColLabelValue

getRowLabels,getColumnLabels :: Grid -> IO [String]
getRowLabels grid = do
  n <- numDataRows grid
  forM [0..n-1] $ flip getRowLabel grid
getColumnLabels grid = do
  n <- numDataColumns grid
  forM [0..n-1] $ flip getColumnLabel grid

setRowLabel,setColumnLabel :: Int -> String -> Grid -> IO ()
setRowLabel n s grid = WXC.gridSetRowLabelValue grid n s
setColumnLabel n s grid = WXC.gridSetColLabelValue grid n s

getRowValues,getColumnValues :: Int -> Grid -> IO [String]
getRowValues n grid = do
  cols <- numDataColumns grid
  forM [0..cols-1] $ \i -> getValue (n,i) grid
getColumnValues n grid = do
  rows <- numDataRows grid
  forM [0..rows-1] $ \i -> getValue (i,n) grid

addRows,addColumns :: [String] -> Grid -> IO ()
addRows names grid = 
    let ls = length names
    in do n <- numDataRows grid
          WXC.gridAppendRows grid ls True
          forM_ (zip [n..] names) $ \(i,name) -> 
              setRowLabel i name grid
          setRowLabel (n + ls) "..." grid

addColumns names grid = 
    let ls = length names
    in do n <- numDataColumns grid
          WXC.gridAppendCols grid ls True
          forM_ (zip [n..] names) $ \(i,name) -> 
              setColumnLabel i name grid
          setColumnLabel (n + ls) "..." grid

insertRowBefore,insertColumnBefore :: String -> Int -> Grid -> IO ()
insertRowBefore name i grid = do
  labels <- do (pre,post) <- splitAt i <$> getRowLabels grid
               return $ pre ++ [name] ++ post               
  WXC.gridInsertRows grid i 1 True
  resetRowLabels labels grid

insertColumnBefore name i grid = do
  labels <- do (pre,post) <- splitAt i <$> getColumnLabels grid
               return $ pre ++ [name] ++ post               
  WXC.gridInsertCols grid i 1 True
  resetColumnLabels labels grid

deleteRows :: [Int] -> Grid -> IO ()
deleteRows rows grid = do
  assert (reverse (sort rows) == rows) $ return ()
  labels <- getRowLabels grid
  forM_ rows $ \i -> WXC.gridDeleteRows grid i 1 True
  resetRowLabels (deleteByIndices rows labels) grid

deleteColumns :: [Int] -> Grid -> IO ()
deleteColumns cols grid = do
  assert (reverse (sort cols) == cols) $ return ()
  labels <- getColumnLabels grid
  forM_ cols $ \i -> WXC.gridDeleteCols grid i 1 True
  resetColumnLabels (deleteByIndices cols labels) grid

-- Reset labels (because of buggy gridDelete* and gridInsert*)
resetRowLabels,resetColumnLabels :: [String] -> Grid -> IO ()
resetRowLabels labels grid = do
  forM (zip [0..] labels) $ \(row,label) -> 
      setRowLabel row label grid
  numDataRows grid >>= \n -> setRowLabel n "..." grid

resetColumnLabels labels grid = do
  forM (zip [0..] labels) $ \(col,label) -> 
      setColumnLabel col label grid
  numDataColumns grid >>= \n -> setColumnLabel n "..." grid