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