-- | Note: the core types and comibnators
--   from this module are from Toxaris in a #haskell
--   conversation on 2008-08-24
{-# LANGUAGE FlexibleContexts #-}

module Text.Tabular where

import Data.List (intersperse)
import Control.Monad.State (evalState, State, 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"]
-- >   ]
--
-- > -- Text.Tabular.AsciiArt.render id id id example
-- > --
-- > --     || memtest 1 | memtest 2 ||  time test  | 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]]

-- ----------------------------------------------------------------------
--
-- ----------------------------------------------------------------------

{-
-- | A 'Table' of "FancyCell"
type FancyTable d a = Table (FancyCell d a)

-- | 'FancyCell' @decorations a@ is a table cell that is associated with
--   decorations of your choosing (for example, a cell colour) as well as
--   instructions to merge that cell with its neighbours down or to the
--   right.  We include special versions of the rendering functions that
--   recognise the merge instructions, but you will have to supply the
--   code that deals with the decorations.
type FancyCell decorations a = (a, Maybe decorations, Maybe MergeInfo)


data MergeInfo = MergeInfo { mergeDown :: Int
                           , mergeRight :: Int
                           }
-}

-- ----------------------------------------------------------------------
-- * Helper functions for rendering
-- ----------------------------------------------------------------------

-- | Retrieve the contents of a  header
headerContents :: Header h -> [h]
headerContents :: Header h -> [h]
headerContents (Header h
s) = [h
s]
headerContents (Group Properties
_ [Header h]
hs) = (Header h -> [h]) -> [Header h] -> [h]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Header h -> [h]
forall h. Header h -> [h]
headerContents [Header h]
hs

instance Functor Header where
 fmap :: (a -> b) -> Header a -> Header b
fmap a -> b
f (Header a
s)   = b -> Header b
forall h. h -> Header h
Header (a -> b
f a
s)
 fmap a -> b
f (Group Properties
p [Header a]
hs) = Properties -> [Header b] -> Header b
forall h. Properties -> [Header h] -> Header h
Group Properties
p ((Header a -> Header b) -> [Header a] -> [Header b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> Header a -> Header b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [Header a]
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 :: h -> [h] -> Header a -> Header (h, a)
zipHeader h
e [h]
ss Header a
h = State [h] (Header (h, a)) -> [h] -> Header (h, a)
forall s a. State s a -> s -> a
evalState (Header a -> State [h] (Header (h, a))
forall (m :: * -> *) b.
MonadState [h] m =>
Header b -> m (Header (h, b))
helper Header a
h) [h]
ss
 where
  helper :: Header b -> m (Header (h, b))
helper (Header b
x) =
   do [h]
cells  <- m [h]
forall s (m :: * -> *). MonadState s m => m s
get
      (h, b)
string <- case [h]
cells of
                  []     -> (h, b) -> m (h, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (h
e,b
x)
                  (h
s:[h]
ss) -> [h] -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [h]
ss m () -> m (h, b) -> m (h, b)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (h, b) -> m (h, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (h
s,b
x)
      Header (h, b) -> m (Header (h, b))
forall (m :: * -> *) a. Monad m => a -> m a
return (Header (h, b) -> m (Header (h, b)))
-> Header (h, b) -> m (Header (h, b))
forall a b. (a -> b) -> a -> b
$ (h, b) -> Header (h, b)
forall h. h -> Header h
Header (h, b)
string
  helper (Group Properties
s [Header b]
hs) =
   Properties -> [Header (h, b)] -> Header (h, b)
forall h. Properties -> [Header h] -> Header h
Group Properties
s ([Header (h, b)] -> Header (h, b))
-> m [Header (h, b)] -> m (Header (h, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Header b -> m (Header (h, b))) -> [Header b] -> m [Header (h, b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Header b -> m (Header (h, b))
helper [Header b]
hs

flattenHeader :: Header h -> [Either Properties h]
flattenHeader :: Header h -> [Either Properties h]
flattenHeader (Header h
s) = [h -> Either Properties h
forall a b. b -> Either a b
Right h
s]
flattenHeader (Group Properties
l [Header h]
s) =
  [[Either Properties h]] -> [Either Properties h]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Either Properties h]] -> [Either Properties h])
-> ([Header h] -> [[Either Properties h]])
-> [Header h]
-> [Either Properties h]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Properties h]
-> [[Either Properties h]] -> [[Either Properties h]]
forall a. a -> [a] -> [a]
intersperse [Properties -> Either Properties h
forall a b. a -> Either a b
Left Properties
l] ([[Either Properties h]] -> [[Either Properties h]])
-> ([Header h] -> [[Either Properties h]])
-> [Header h]
-> [[Either Properties h]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header h -> [Either Properties h])
-> [Header h] -> [[Either Properties h]]
forall a b. (a -> b) -> [a] -> [b]
map Header h -> [Either Properties h]
forall h. Header h -> [Either Properties h]
flattenHeader ([Header h] -> [Either Properties h])
-> [Header h] -> [Either Properties h]
forall a b. (a -> b) -> a -> b
$ [Header h]
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 :: (Properties -> b -> b) -> (h -> b) -> Header h -> [b]
squish Properties -> b -> b
decorator h -> b
f Header h
h = [Either Properties h] -> [b]
helper ([Either Properties h] -> [b]) -> [Either Properties h] -> [b]
forall a b. (a -> b) -> a -> b
$ Header h -> [Either Properties h]
forall h. Header h -> [Either Properties h]
flattenHeader Header h
h
 where
  helper :: [Either Properties h] -> [b]
helper [] = []
  helper (Left Properties
p:[Either Properties h]
es)  = [Either Properties h] -> [b]
helper [Either Properties h]
es
  helper (Right h
x:[Either Properties h]
es) =
   case [Either Properties h]
es of
     (Left Properties
p:[Either Properties h]
es2) -> Properties -> b -> b
decorator Properties
p (h -> b
f h
x) b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [Either Properties h] -> [b]
helper [Either Properties h]
es2
     [Either Properties h]
_            -> h -> b
f h
x b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [Either Properties h] -> [b]
helper [Either Properties h]
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 rh ch a
empty = Header rh -> Header ch -> [[a]] -> Table rh ch a
forall rh ch a. Header rh -> Header ch -> [[a]] -> Table rh ch a
Table (Properties -> [Header rh] -> Header rh
forall h. Properties -> [Header h] -> Header h
Group Properties
NoLine []) (Properties -> [Header ch] -> Header ch
forall h. Properties -> [Header h] -> Header h
Group Properties
NoLine []) []

col :: ch -> [a] -> SemiTable ch a
col :: ch -> [a] -> SemiTable ch a
col ch
header [a]
cells = Header ch -> [a] -> SemiTable ch a
forall h a. Header h -> [a] -> SemiTable h a
SemiTable (ch -> Header ch
forall h. h -> Header h
Header ch
header) [a]
cells

-- | Column header
colH :: ch -> SemiTable ch a
colH :: ch -> SemiTable ch a
colH ch
header = ch -> [a] -> SemiTable ch a
forall ch a. ch -> [a] -> SemiTable ch a
col ch
header []

row :: rh -> [a] -> SemiTable rh a
row :: rh -> [a] -> SemiTable rh a
row = rh -> [a] -> SemiTable rh a
forall ch a. ch -> [a] -> SemiTable ch a
col

rowH :: rh -> SemiTable rh a
rowH :: rh -> SemiTable rh a
rowH = rh -> SemiTable rh a
forall ch a. ch -> SemiTable ch a
colH

beside :: Properties -> Table rh ch a -> SemiTable ch a -> Table rh ch a
beside :: Properties -> Table rh ch a -> SemiTable ch a -> Table rh ch a
beside Properties
prop (Table Header rh
rows Header ch
cols1 [[a]]
data1)
            (SemiTable  Header ch
cols2 [a]
data2) =
  Header rh -> Header ch -> [[a]] -> Table rh ch a
forall rh ch a. Header rh -> Header ch -> [[a]] -> Table rh ch a
Table Header rh
rows (Properties -> [Header ch] -> Header ch
forall h. Properties -> [Header h] -> Header h
Group Properties
prop [Header ch
cols1, Header ch
cols2])
             (([a] -> [a] -> [a]) -> [[a]] -> [[a]] -> [[a]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) [[a]]
data1 [[a]
data2])

below :: Properties -> Table rh ch a -> SemiTable rh a -> Table rh ch a
below :: Properties -> Table rh ch a -> SemiTable rh a -> Table rh ch a
below Properties
prop (Table     Header rh
rows1 Header ch
cols [[a]]
data1)
           (SemiTable Header rh
rows2      [a]
data2) =
  Header rh -> Header ch -> [[a]] -> Table rh ch a
forall rh ch a. Header rh -> Header ch -> [[a]] -> Table rh ch a
Table (Properties -> [Header rh] -> Header rh
forall h. Properties -> [Header h] -> Header h
Group Properties
prop [Header rh
rows1, Header rh
rows2]) Header ch
cols ([[a]]
data1 [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [[a]
data2])

-- | besides
(^..^) :: Table rh ch a -> SemiTable ch a -> Table rh ch a
^..^ :: Table rh ch a -> SemiTable ch a -> Table rh ch a
(^..^) = Properties -> Table rh ch a -> SemiTable ch a -> Table rh ch a
forall rh ch a.
Properties -> Table rh ch a -> SemiTable ch a -> Table rh ch a
beside Properties
NoLine
-- | besides with a line
(^|^)  :: Table rh ch a -> SemiTable ch a -> Table rh ch a
^|^ :: Table rh ch a -> SemiTable ch a -> Table rh ch a
(^|^)  = Properties -> Table rh ch a -> SemiTable ch a -> Table rh ch a
forall rh ch a.
Properties -> Table rh ch a -> SemiTable ch a -> Table rh ch a
beside Properties
SingleLine
-- | besides with a double line
(^||^) :: Table rh ch a -> SemiTable ch a -> Table rh ch a
^||^ :: Table rh ch a -> SemiTable ch a -> Table rh ch a
(^||^) = Properties -> Table rh ch a -> SemiTable ch a -> Table rh ch a
forall rh ch a.
Properties -> Table rh ch a -> SemiTable ch a -> Table rh ch a
beside Properties
DoubleLine

-- | below
(+.+) :: Table rh ch a -> SemiTable rh a -> Table rh ch a
+.+ :: Table rh ch a -> SemiTable rh a -> Table rh ch a
(+.+) = Properties -> Table rh ch a -> SemiTable rh a -> Table rh ch a
forall rh ch a.
Properties -> Table rh ch a -> SemiTable rh a -> Table rh ch a
below Properties
NoLine
-- | below with a line
(+----+) :: Table rh ch a -> SemiTable rh a -> Table rh ch a
+----+ :: Table rh ch a -> SemiTable rh a -> Table rh ch a
(+----+) = Properties -> Table rh ch a -> SemiTable rh a -> Table rh ch a
forall rh ch a.
Properties -> Table rh ch a -> SemiTable rh a -> Table rh ch a
below Properties
SingleLine
-- | below with a double line
(+====+) :: Table rh ch a -> SemiTable rh a -> Table rh ch a
+====+ :: Table rh ch a -> SemiTable rh a -> Table rh ch a
(+====+) = Properties -> Table rh ch a -> SemiTable rh a -> Table rh ch a
forall rh ch a.
Properties -> Table rh ch a -> SemiTable rh a -> Table rh ch a
below Properties
DoubleLine