happs-tutorial-0.4.1: src/ViewPagination.hs

{-# LANGUAGE NoMonomorphismRestriction #-}
module ViewPagination where

import Data.List
import Misc
import Text.StringTemplate
data Pagination = Pagination { currentpage :: Int
                              , resultsPerPage :: Int 
                              , baselink :: String
                              , paginationtitle :: String 
                             }

paginationRanges :: Pagination -> [a] -> [[(a,Int)]]
paginationRanges pg datacells = splitList (resultsPerPage pg) $ zip datacells [1..]

paintPaginationBar :: STGroup String -> [[String]] -> Pagination -> String
paintPaginationBar templates datacells pg  =
  let r = renderTemplateGroup templates
      paintlink (pageindex,range) = case range of
                [] -> ""
                (_,fr):xs -> let to = last . map snd $ xs
                                 attrs = [("currentpage",show pageindex),
                                          ("resultsPerPage",show $ resultsPerPage pg),
                                          ("from",show fr),
                                          ("to",show to)]
                             in if (currentpage pg) == pageindex
                                   then  r attrs "paginationlinkselected"  
                                   else r attrs "paginationlinkunselected" 
      pglinks = map paintlink $ zip [1..] (paginationRanges pg datacells )

  in (paginationtitle pg) ++ ( concat . intersperse " | " $ pglinks )



getPaginatedCells datacells pg = fromTo fromRow toRow datacells
        where (fromRow,toRow) = currentPaginationFromTo datacells pg

currentPaginationFromTo :: [[a]] -> Pagination -> (Int,Int)
currentPaginationFromTo datacells pg =
  --let currentPaginationRange = paginationRanges pg datacells !! ( (currentpage pg) -1)
  case paginationRanges pg datacells of
    [] -> (0,0)
    prs -> let currrange = prs !! ((currentpage pg)-1)
           in  case currrange of
             [] -> (0,0)
             ((firstval,firstindex):xs) -> (firstindex, (last . map snd ) xs)


splitList :: Int -> [a] -> [[a]]
splitList _ [] = []
splitList n l@(x:xs) =
  let (a,b') = genericSplitAt n l 
      b = splitList n b'
  in  a : b