tabloid-0.3: TableController.hs

module TableController
    (
     Controller
    , test
    , new
    , view
    , push    
    ) where
    
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Graphics.UI.Gtk.ModelView as MV 
import qualified LoadSaveController as LSC
import qualified TableView as View
import Graphics.UI.Gtk
import Data.Maybe
import Data.List
import SimpleRegex
import Control.Monad
import Control.Applicative
import WindowedApp
import Component

type Controller = Ref C

type StringList = MV.ListStore [L.ByteString]

view :: C -> Widget
view = View.mainWidget . gui

new :: IO Controller
new = do
  lsc <- LSC.new (Just "jira")
  lsv <- (lsc .> LSC.view)
  l <- MV.listStoreNew [] 
  v <- View.new l lsv
  lsc .< (LSC.onSave (Just (Just <$> toJira l)))
  onClicked (View.searchPB v) (searchTableBackward (View.searchE v) l (View.treeView v))
  onClicked (View.searchNB v) (searchTableForward (View.searchE v) l (View.treeView v))
  View.add_col (View.treeView v) l (L.unpack . (!! 0)) "Line" 0
  this <- newRef (C v l 1 Nothing)
  onToggled (View.groupB v) (this .<< updateGrouping)
  onValueSpinned (View.groupE v) (this .<< updateGrouping)
  return this

push this rows = 
  this .<< \s -> 
      case groupCol s of
        Nothing -> 
           pushRaw (zipWith (:) (map (L.pack . show) [1..]) rows) s
        Just (c, _) ->
           pushRaw (zipWith (:) (map (L.pack . show) [1..]) rows) (s {groupCol = Just (c, rows)})

-- internal functions
groupRows [] _ = []
groupRows (row:rows) col = row : sameGroup ++ groupRows rest col
    where cell = row !! col
          (sameGroup, rest) = partition ((== cell) . (!! col)) rows 


updateGrouping state@(C g listM mc gCol) = 
    do
      col <- spinButtonGetValueAsInt (View.groupE g)
      grouping <- toggleButtonGetActive (View.groupB g)
      if grouping then 
          do
            rows <- MV.listStoreToList listM            
            case gCol of
              Nothing ->                   
                  pushRaw rows (state { groupCol = Just (col, rows)})
              Just (ccol, crows) ->
                  pushRaw crows (state { groupCol = Just (col, crows)})

          else
              case gCol of
                Nothing -> 
                    return (state { groupCol = Nothing }) 
                Just (ccols, crows) ->
                    pushRaw crows (state { groupCol = Nothing})
                    

searchTableBackward entry liststore treeview = do
  selI <- getSelectedRow treeview
  rows' <- MV.listStoreToList liststore
  let rows = reverse $ zip [0..] (take selI rows')
  searchRowRange rows entry treeview

searchTableForward entry liststore treeview = do
  selI <- getSelectedRow treeview
  rows' <- MV.listStoreToList liststore
  let rows = zip [(selI + 1) ..] (drop (selI + 1) rows')
  searchRowRange rows entry  treeview

searchRowRange rows entry treeview = do
  searchTerm <- entryGetText entry
  let sI = filter (any (isInfixOf searchTerm) . (map L.unpack) . snd)  rows
  case sI of
    ((nexti, _):_) -> do
            MV.treeViewSetCursor treeview [nexti] Nothing
    _ -> 
        beep

getSelectedRow treeV = do
  tsel <- MV.treeViewGetSelection treeV
  sel <-  MV.treeSelectionGetSelectedRows tsel
  return $ case sel of
             ((fst_sel:_):_) -> fst_sel
             _ -> 0

{-
toCsv :: StringList -> IO L.ByteString 
toCsv liststore = do
  cont <- MV.listStoreToList liststore
  return (L.unlines (lineToCsv <$> cont))
    where
      lineToCsv :: [L.ByteString] -> L.ByteString
      lineToCsv ls = 
          let els = doQuotes <$> ls
          in L.concat (intersperse (L.pack ";") els)
      doQuotes :: L.ByteString -> L.ByteString
      doQuotes cont = 
          let escaped = L.foldl' (\s c -> 
                                      s `L.append` 
                                            (if c == '"' 
                                              then L.pack ['\\', c] 
                                              else L.pack [c])) 
                        L.empty
                        cont
          in (L.pack "\"") `L.append` escaped `L.append` (L.pack "\"")
-}
toJira :: StringList -> IO L.ByteString 
toJira liststore = do
  cont <- MV.listStoreToList liststore
  return (L.unlines (lineToCsv <$> cont))
    where
      lineToCsv :: [L.ByteString] -> L.ByteString
      lineToCsv ls = 
          let els = escape <$> ls
          in (L.pack "| ") `L.append` 
             L.concat (intersperse (L.pack " | ") els) `L.append` (L.pack " |")
      escape :: L.ByteString -> L.ByteString
      escape cont = L.foldl' (\s c -> 
                                  s `L.append` 
                                        (if c == '|' 
                                          then L.pack ['\\', c] 
                                          else L.pack [c])) 
                    L.empty
                    cont

pushRaw :: [[L.ByteString]] -> C -> IO C
pushRaw rows c@(C g listM mc groupCol) =
    let 
      addRows n [] = return n
      addRows n (r:rs) = do
        let r' = length r
        when (r' > n) $ forM_ [n .. r' - 1] 
                 (\i -> 
                      View.add_col (View.treeView g)
                          listM (at i) ("$" ++ show i) i)
        (MV.listStoreAppend listM) r
        addRows (max n r') rs
      at :: Int -> [L.ByteString] -> String
      at i xs 
         | (length xs) <= i =  ""
         | otherwise        = L.unpack $ xs !! i
    in 
      do
        (MV.listStoreClear listM)
        rowcount <- spinButtonGetValueAsInt (View.maxLines g)
        let groupedRows = maybe selRows (groupRows selRows . fst) groupCol
            selRows = (take rowcount rows)            
        cs <- addRows mc groupedRows
        spinButtonSetRange (View.groupE g) 0 (fromIntegral (cs - 1))
        return (c { cols = cs })

data C = C 
    { 
      gui :: View.ViewState
    , listModel :: StringList
    , cols :: Int
    , groupCol :: Maybe (Int, [[L.ByteString]])
    }


-- tests
test = windowedApp "TableController test" $ do
         t <- new  :: IO Controller
         t `push` [[(L.pack . show) (c `rem` 3)| c <- [r .. r + 10]] | r <- [0 .. 9]]        
         t .> view