module Data.Table (
Alignment(..)
, Table
, toList
, alignments
, defaultAlignment
, columns
, rows
, empty
, fromList
, newRow
, setAlignment
, appendCell
, appendNumCell
, getCell
, setCell
, headerLastCell
, alignLastCell
, toLaTeX
) where
import Safe
import Data.List
import qualified Data.IntMap as IM
import Extension.Prelude
roundDecimal :: RealFrac a
=> Int
-> a -> a
roundDecimal d n = fromIntegral ((round (multiplier * n))::Integer) / multiplier
where
multiplier :: RealFrac a => a
multiplier = 10 ^^ d
maxKey :: IM.IntMap a -> Maybe Int
maxKey = fmap (fst.fst) . IM.maxViewWithKey
denseLength :: IM.IntMap a -> Int
denseLength = maybe 0 succ . maxKey
toDenseList :: a -> IM.IntMap a -> [a]
toDenseList def m = case maxKey m of
Just k -> merge [0..k] (IM.toList m)
Nothing -> []
where
merge [] vs = map snd vs
merge ks [] = replicate (length ks) def
merge ks@(k:ks') vs@((idx,v):vs') = case compare k idx of
LT -> def : merge ks' vs
EQ -> v : merge ks' vs'
GT -> v : merge ks vs'
fromDenseList :: [a] -> IM.IntMap a
fromDenseList = IM.fromList . zip [0..]
type Cells a = IM.IntMap (IM.IntMap a)
data Alignment = AlignLeft | AlignRight
deriving( Eq, Ord, Show )
data Table a = Table {
alignments :: IM.IntMap Alignment
, headers :: IM.IntMap a
, getCells :: Cells a
}
deriving( Eq, Ord, Show )
instance Functor Table where
fmap f = mapCellsAndHeaders (IM.map (IM.map f)) (IM.map f)
defaultAlignment :: Alignment
defaultAlignment = AlignLeft
columns :: Table a -> Int
columns = maximumDef 0 . map (denseLength . snd) . IM.toList . getCells
rows :: Table a -> Int
rows = denseLength . getCells
getCell :: (Int,Int) -> Table a -> Maybe a
getCell (rowIdx, colIdx) = (IM.lookup colIdx =<<) . IM.lookup rowIdx . getCells
viewLastCell :: Table a -> Maybe ((Int, Int), a)
viewLastCell t = do
((rowIdx,row), _) <- IM.maxViewWithKey $ getCells t
((colIdx,cell), _) <- IM.maxViewWithKey $ row
return ((rowIdx, colIdx), cell)
lastCellIndex :: Table a -> Maybe (Int, Int)
lastCellIndex = fmap fst . viewLastCell
toList :: a -> Table a -> [[a]]
toList def = map (toDenseList def) . toDenseList IM.empty . getCells
mapAlignments :: (IM.IntMap Alignment -> IM.IntMap Alignment) -> Table a -> Table a
mapAlignments f t = t { alignments = f (alignments t) }
mapHeaders :: (IM.IntMap a -> IM.IntMap a) -> Table a -> Table a
mapHeaders f = mapCellsAndHeaders id f
mapCells :: (Cells a -> Cells a) -> Table a -> Table a
mapCells f = mapCellsAndHeaders f id
mapCellsAndHeaders :: (Cells a -> Cells b)
-> (IM.IntMap a -> IM.IntMap b)
-> Table a -> Table b
mapCellsAndHeaders fCells fHeaders t =
t { headers = fHeaders (headers t), getCells = fCells (getCells t) }
empty :: Table a
empty = Table IM.empty IM.empty IM.empty
fromList :: [[a]] -> Table a
fromList = Table IM.empty IM.empty . fromDenseList . map fromDenseList
setAlignment :: Int -> Alignment -> Table a -> Table a
setAlignment colIdx alignment = mapAlignments (IM.insert colIdx alignment)
setHeader :: Int -> a -> Table a -> Table a
setHeader colIdx header = mapHeaders (IM.insert colIdx header)
setCell :: (Int,Int) -> a -> Table a -> Table a
setCell idx@(rowIdx, colIdx) x
| rowIdx < 0 || colIdx < 0 = error $ "setCell: index out of range" ++ show idx
| otherwise = mapCells (IM.alter changeRow rowIdx)
where
changeRow Nothing = Just $ IM.singleton colIdx x
changeRow (Just row) = Just $ IM.insert colIdx x row
newRow :: Table a -> Table a
newRow = mapCells $ \cells -> case maxKey cells of
Just rowIdx -> IM.insert (succ rowIdx) IM.empty cells
Nothing -> IM.singleton 0 IM.empty
appendCell :: a -> Table a -> Table a
appendCell cell = mapCells $ \cells ->
case IM.maxViewWithKey cells of
Just ((rowIdx,row),cellsNoRow) ->
case maxKey row of
Just colIdx -> IM.insert rowIdx (IM.insert (succ colIdx) cell row) cellsNoRow
Nothing -> IM.insert rowIdx (IM.singleton 0 cell) cellsNoRow
Nothing -> IM.singleton 0 (IM.singleton 0 cell)
alignLastCell :: Alignment -> Table a -> Table a
alignLastCell al t = case lastCellIndex t of
Just (_, colIdx) -> setAlignment colIdx al t
Nothing -> t
headerLastCell :: a -> Table a -> Table a
headerLastCell header t = case lastCellIndex t of
Just (_, colIdx) -> setHeader colIdx header t
Nothing -> t
appendNumCell :: RealFrac a
=> Int
-> a -> Table String -> Table String
appendNumCell dec x =
alignLastCell AlignRight . appendCell (show $ roundDecimal dec x)
type Aligner a = Int
-> [a]
-> [a]
alignBy :: Aligner a -> [[a]] -> [[a]]
alignBy _ [] = []
alignBy expand rs = map (expand maxLength) rs
where
maxLength = maximum $ map length rs
alignCellsBy :: [Aligner a] -> [[[a]]] -> [[[a]]]
alignCellsBy expanders =
transpose . zipWith alignBy (cycle expanders) . transpose . alignBy (flushLeftBy [[]])
toLaTeX :: (a -> String) -> Table a -> String
toLaTeX toStr t =
formatLines . map formatLine . alignCells . addHeaders . toList "" . fmap toStr $ t
where
addHeaders
| IM.null $ headers t = id
| otherwise = ((toDenseList "" . IM.map toStr $ headers t):)
doAlign AlignLeft = flushLeft
doAlign AlignRight = flushRight
aligns = toDenseList defaultAlignment (alignments t) ++ repeat defaultAlignment
alignCells = alignCellsBy (map doAlign aligns)
formatLine = (++"\\\\") . concat . intersperse " & "
formatLines = unlines