tabloid-0.44: 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 liststore = withRows liststore (formatLine 
                                      [('"', L.pack "\"\"")] 
                                      (L.pack "\"") 
                                      (L.pack ";"))

toJira liststore = withRows liststore 
                     (((pipeSym `L.append`) . 
                       (`L.append` pipeSym)) .
                      (formatLine [] L.empty pipeSym))
    where
      pipeSym = L.pack "|"

withRows :: StringList -> ([L.ByteString] -> L.ByteString) -> IO L.ByteString
withRows liststore action = do
  cont <- MV.listStoreToList liststore
  return (L.unlines (action <$> cont))

formatLine repl quot sep = (intercal sep) . (map $ embedString quot) . (map $ replaceChars repl) 

embedString :: L.ByteString -> L.ByteString -> L.ByteString
embedString es = (es `L.append`) . (`L.append` es)

intercal :: L.ByteString -> [L.ByteString] -> L.ByteString 
intercal = (L.concat .) . intersperse

replaceChars :: [(Char,L.ByteString)] -> L.ByteString -> L.ByteString
replaceChars tab = L.foldl'
                     (\s c -> 
                          s `L.append` fromJust (lookup c tab `mplus` Just (L.pack [c])))
                     L.empty
                       
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