Grid.hs

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

import Control.Exception (assert)
import Control.Monad (forM,forM_)
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

addRow,addColumn :: String -> Grid -> IO ()
addRow name grid = do
  n <- numDataRows grid
  WXC.gridAppendRows grid 1 True
  setRowLabel n name grid
  setRowLabel (n+1) "..." grid
addColumn name grid = do
  n <- numDataColumns grid
  WXC.gridAppendCols grid 1 True
  setColumnLabel n name grid
  setColumnLabel (n+1) "..." 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

  -- Reset labels (because of buggy gridDeleteCols)
  forM (zip [0..] $ deleteByIndices cols labels) $ \(col,label) -> 
      setColumnLabel col label grid

  numDataColumns grid >>= \n -> setColumnLabel n "..." 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

  -- Reset labels (because of buggy gridDeleteCols)
  forM (zip [0..] $ deleteByIndices rows labels) $ \(row,label) ->
      setRowLabel row label grid

  numDataRows grid >>= \n -> setRowLabel n "..." grid