Common/Lib/Tabular.hs

{- |
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]