-- | 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
                deriving (Int -> Properties -> ShowS
[Properties] -> ShowS
Properties -> String
(Int -> Properties -> ShowS)
-> (Properties -> String)
-> ([Properties] -> ShowS)
-> Show Properties
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Properties] -> ShowS
$cshowList :: [Properties] -> ShowS
show :: Properties -> String
$cshow :: Properties -> String
showsPrec :: Int -> Properties -> ShowS
$cshowsPrec :: Int -> Properties -> ShowS
Show)
data Header h = Header h | Group Properties [Header h]
              deriving (Int -> Header h -> ShowS
[Header h] -> ShowS
Header h -> String
(Int -> Header h -> ShowS)
-> (Header h -> String) -> ([Header h] -> ShowS) -> Show (Header h)
forall h. Show h => Int -> Header h -> ShowS
forall h. Show h => [Header h] -> ShowS
forall h. Show h => Header h -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Header h] -> ShowS
$cshowList :: forall h. Show h => [Header h] -> ShowS
show :: Header h -> String
$cshow :: forall h. Show h => Header h -> String
showsPrec :: Int -> Header h -> ShowS
$cshowsPrec :: forall h. Show h => Int -> Header h -> ShowS
Show)

-- |
-- > 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]]
                   deriving (Int -> Table rh ch a -> ShowS
[Table rh ch a] -> ShowS
Table rh ch a -> String
(Int -> Table rh ch a -> ShowS)
-> (Table rh ch a -> String)
-> ([Table rh ch a] -> ShowS)
-> Show (Table rh ch a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall rh ch a.
(Show rh, Show ch, Show a) =>
Int -> Table rh ch a -> ShowS
forall rh ch a.
(Show rh, Show ch, Show a) =>
[Table rh ch a] -> ShowS
forall rh ch a.
(Show rh, Show ch, Show a) =>
Table rh ch a -> String
showList :: [Table rh ch a] -> ShowS
$cshowList :: forall rh ch a.
(Show rh, Show ch, Show a) =>
[Table rh ch a] -> ShowS
show :: Table rh ch a -> String
$cshow :: forall rh ch a.
(Show rh, Show ch, Show a) =>
Table rh ch a -> String
showsPrec :: Int -> Table rh ch a -> ShowS
$cshowsPrec :: forall rh ch a.
(Show rh, Show ch, Show a) =>
Int -> Table rh ch a -> ShowS
Show)

-- ----------------------------------------------------------------------
-- * 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]
                   deriving (Int -> SemiTable h a -> ShowS
[SemiTable h a] -> ShowS
SemiTable h a -> String
(Int -> SemiTable h a -> ShowS)
-> (SemiTable h a -> String)
-> ([SemiTable h a] -> ShowS)
-> Show (SemiTable h a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall h a. (Show h, Show a) => Int -> SemiTable h a -> ShowS
forall h a. (Show h, Show a) => [SemiTable h a] -> ShowS
forall h a. (Show h, Show a) => SemiTable h a -> String
showList :: [SemiTable h a] -> ShowS
$cshowList :: forall h a. (Show h, Show a) => [SemiTable h a] -> ShowS
show :: SemiTable h a -> String
$cshow :: forall h a. (Show h, Show a) => SemiTable h a -> String
showsPrec :: Int -> SemiTable h a -> ShowS
$cshowsPrec :: forall h a. (Show h, Show a) => Int -> SemiTable h a -> ShowS
Show)

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]
xs a
x -> [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x]) [[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