{- |

Module : ./Common/Lib/Tabular.hs

Description : parts of the tabular package

Copyright : (c) Eric Kow <E.Y.Kow@brighton.ac.uk>

License : BSD3

Maintainer : Christian.Maeder@dfki.de

Stability : provisional

Portability : portable

-}

module Common.Lib.Tabular where

import Data.List (intercalate, transpose)

import Common.Lib.State (evalState, get, put)

data Properties = NoLine | SingleLine | DoubleLine

data Header h = Header h | Group Properties [Header h]

{- |

> example = Table

> (Group SingleLine

> [ Group NoLine [Header "A 1", Header "A 2"]

> , Group NoLine [Header "B 1", Header "B 2", Header "B 3"]

> ])

> (Group DoubleLine

> [ Group SingleLine [Header "memtest 1", Header "memtest 2"]

> , Group SingleLine [Header "time test 1", Header "time test 2"]

> ])

> [ ["hog", "terrible", "slow", "slower"]

> , ["pig", "not bad", "fast", "slowest"]

> , ["good", "awful" , "intolerable", "bearable"]

> , ["better", "no chance", "crawling", "amazing"]

> , ["meh", "well...", "worst ever", "ok"]

> ]

> > putStr $ render id id id example

> +-----++-----------+-----------++-------------+-------------+

> | || memtest 1 | memtest 2 || time test 1 | time test 2 |

> +=====++===========+===========++=============+=============+

> | A 1 || hog | terrible || slow | slower |

> | A 2 || pig | not bad || fast | slowest |

> +-----++-----------+-----------++-------------+-------------+

> | B 1 || good | awful || intolerable | bearable |

> | B 2 || better | no chance || crawling | amazing |

> | B 3 || meh | well... || worst ever | ok |

> +-----++-----------+-----------++-------------+-------------+

-}

data Table rh ch a = Table (Header rh) (Header ch) [[a]]

-- * Helper functions for rendering

-- | Retrieve the contents of a header

headerContents :: Header h -> [h]

headerContents (Header s) = [s]

headerContents (Group _ hs) = concatMap headerContents hs

instance Functor Header where

fmap f (Header s) = Header (f s)

fmap f (Group p hs) = Group p (map (fmap f) hs)

{- | 'zipHeader' @e@ @ss@ @h@ returns the same structure

as @h@ except with all the text replaced by the contents

of @ss@.

If @ss@ has too many cells, the excess is ignored.

If it has too few cells, the missing ones (at the end)

and replaced with the empty contents @e@.

-}

zipHeader :: h -> [h] -> Header a -> Header (h, a)

zipHeader e ss h = evalState (helper h) ss

where

helper (Header x) =

do cells <- get

string <- case cells of

[] -> return (e, x)

s : xs -> put xs >> return (s, x)

return $ Header string

helper (Group s hs) =

Group s `fmap` mapM helper hs

flattenHeader :: Header h -> [Either Properties h]

flattenHeader (Header s) = [Right s]

flattenHeader (Group l s) = intercalate [Left l] . map flattenHeader $ s

{- | The idea is to deal with the fact that Properties

(e.g. borders) are not standalone cells but attributes

of a cell. A border is just a CSS decoration of a

TD element.

squish @decorator f h@ applies @f@ to every item

in the list represented by @h@ (see 'flattenHeader'),

additionally applying @decorator@ if the item is

followed by some kind of boundary

So

@

o o o | o o o | o o

@

gets converted into

@

O O X O O X O O

@

-}

squish :: (Properties -> b -> b)

-> (h -> b)

-> Header h

-> [b]

squish decorator f h = helper $ flattenHeader h

where

helper [] = []

helper (Left _ : es) = helper es

helper (Right x : es) =

case es of

(Left p : es2) -> decorator p (f x) : helper es2

_ -> f x : helper es

-- * Combinators

{- | Convenience type for just one row (or column).

To be used with combinators as follows:

> example2 =

> empty ^..^ col "memtest 1" [] ^|^ col "memtest 2" []

> ^||^ col "time test "[] ^|^ col "time test 2" []

> +.+ row "A 1" ["hog", "terrible", "slow", "slower"]

> +.+ row "A 2" ["pig", "not bad", "fast", "slowest"]

> +----+

> row "B 1" ["good", "awful", "intolerable", "bearable"]

> +.+ row "B 2" ["better", "no chance", "crawling", "amazing"]

> +.+ row "B 3" ["meh", "well...", "worst ever", "ok"]

-}

data SemiTable h a = SemiTable (Header h) [a]

empty :: Table rh ch a

empty = Table (Group NoLine []) (Group NoLine []) []

col :: ch -> [a] -> SemiTable ch a

col = SemiTable . Header

-- | Column header

colH :: ch -> SemiTable ch a

colH header = col header []

row :: rh -> [a] -> SemiTable rh a

row = col

rowH :: rh -> SemiTable rh a

rowH = colH

beside :: Properties -> Table rh ch a -> SemiTable ch a -> Table rh ch a

beside prop (Table rows cols1 data1)

(SemiTable cols2 data2) =

Table rows (Group prop [cols1, cols2])

(zipWith (++) data1 [data2])

below :: Properties -> Table rh ch a -> SemiTable rh a -> Table rh ch a

below prop (Table rows1 cols data1)

(SemiTable rows2 data2) =

Table (Group prop [rows1, rows2]) cols (data1 ++ [data2])

-- | besides

(^..^) :: Table rh ch a -> SemiTable ch a -> Table rh ch a

(^..^) = beside NoLine

-- | besides with a line

(^|^) :: Table rh ch a -> SemiTable ch a -> Table rh ch a

(^|^) = beside SingleLine

-- | besides with a double line

(^||^) :: Table rh ch a -> SemiTable ch a -> Table rh ch a

(^||^) = beside DoubleLine

-- | below

(+.+) :: Table rh ch a -> SemiTable rh a -> Table rh ch a

(+.+) = below NoLine

-- | below with a line

(+----+) :: Table rh ch a -> SemiTable rh a -> Table rh ch a

(+----+) = below SingleLine

-- | below with a double line

(+====+) :: Table rh ch a -> SemiTable rh a -> Table rh ch a

(+====+) = below DoubleLine

-- * ascii art

-- | for simplicity, we assume that each cell is rendered on a single line

render :: (rh -> String)

-> (ch -> String)

-> (a -> String)

-> Table rh ch a

-> String

render fr fc f (Table rh ch cells) =

unlines $ [ bar SingleLine -- +--------------------------------------+

, renderColumns sizes ch2

, bar DoubleLine -- +======================================+

] ++

renderRs (fmap renderR $ zipHeader [] cells $ fmap fr rh) ++

[ bar SingleLine ] -- +--------------------------------------+

where

bar = concat . renderHLine sizes ch2

-- ch2 and cell2 include the row and column labels

ch2 = Group DoubleLine [Header "", fmap fc ch]

cells2 = headerContents ch2

: zipWith (\ h cs -> h : map f cs) rhStrings cells

renderR (cs, h) = renderColumns sizes $ Group DoubleLine

[ Header h

, fmap fst $ zipHeader "" (map f cs) ch]

rhStrings = map fr $ headerContents rh

-- maximum width for each column

sizes = map (maximum . map length) . transpose $ cells2

renderRs (Header s) = [s]

renderRs (Group p hs) = intercalate sep . map renderRs $ hs

where sep = renderHLine sizes ch2 p

-- | We stop rendering on the shortest list!

renderColumns :: [Int] -- ^ max width for each column

-> Header String

-> String

renderColumns is h = "| " ++ coreLine ++ " |"

where

coreLine = concatMap helper $ flattenHeader $ zipHeader 0 is h

padLeft (l, s) = replicate (l - length s) ' ' ++ s

helper = either hsep padLeft

hsep :: Properties -> String

hsep NoLine = " "

hsep SingleLine = " | "

hsep DoubleLine = " || "

renderHLine :: [Int] -- ^ width specifications

-> Header String

-> Properties

-> [String]

renderHLine _ _ NoLine = []

renderHLine w h SingleLine = [renderHLine' w '-' h]

renderHLine w h DoubleLine = [renderHLine' w '=' h]

renderHLine' :: [Int] -> Char -> Header String -> String

renderHLine' is sep h = [ '+', sep ] ++ coreLine ++ [sep, '+']

where

coreLine = concatMap helper $ flattenHeader $ zipHeader 0 is h

helper = either vsep dashes

dashes (i, _) = replicate i sep

vsep NoLine = [sep]

vsep SingleLine = sep : '+' : [sep]

vsep DoubleLine = sep : "++" ++ [sep]