-- | Table combinators for XHTML.
module Text.XHtml.Table (HtmlTable, HTMLTABLE(..),
                        (</>), above, (<->), beside, 
                         aboves, besides,
                         simpleTable) where

import Text.XHtml.Internals
import Text.XHtml.Strict.Elements
import Text.XHtml.Strict.Attributes

import qualified Text.XHtml.BlockTable as BT


infixr 3 </>  -- combining table cells 
infixr 4 <->  -- combining table cells

--
-- * Tables
--

class HTMLTABLE ht where
      cell :: ht -> HtmlTable

instance HTMLTABLE HtmlTable where
      cell :: HtmlTable -> HtmlTable
cell = HtmlTable -> HtmlTable
forall a. a -> a
id

instance HTMLTABLE Html where
      cell :: Html -> HtmlTable
cell Html
h = 
         let
              cellFn :: Int -> Int -> Html
cellFn Int
x Int
y = Html
h Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! (Int -> (Int -> HtmlAttr) -> [HtmlAttr] -> [HtmlAttr]
forall {t} {a}. (Eq t, Num t) => t -> (t -> a) -> [a] -> [a]
add Int
x Int -> HtmlAttr
colspan ([HtmlAttr] -> [HtmlAttr]) -> [HtmlAttr] -> [HtmlAttr]
forall a b. (a -> b) -> a -> b
$ Int -> (Int -> HtmlAttr) -> [HtmlAttr] -> [HtmlAttr]
forall {t} {a}. (Eq t, Num t) => t -> (t -> a) -> [a] -> [a]
add Int
y Int -> HtmlAttr
rowspan ([HtmlAttr] -> [HtmlAttr]) -> [HtmlAttr] -> [HtmlAttr]
forall a b. (a -> b) -> a -> b
$ [])
              add :: t -> (t -> a) -> [a] -> [a]
add t
1 t -> a
_  [a]
rest = [a]
rest
              add t
n t -> a
fn [a]
rest = t -> a
fn t
n a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
rest
              r :: BlockTable (Int -> Int -> Html)
r = (Int -> Int -> Html) -> BlockTable (Int -> Int -> Html)
forall a. a -> BlockTable a
BT.single Int -> Int -> Html
cellFn
         in 
              BlockTable (Int -> Int -> Html) -> HtmlTable
mkHtmlTable BlockTable (Int -> Int -> Html)
r

-- | We internally represent the Cell inside a Table with an
-- object of the type
--
-- >	   Int -> Int -> Html
--
-- When we render it later, we find out how many columns
-- or rows this cell will span over, and can
-- include the correct colspan\/rowspan command.
newtype HtmlTable 
      = HtmlTable (BT.BlockTable (Int -> Int -> Html))


mkHtmlTable :: BT.BlockTable (Int -> Int -> Html) -> HtmlTable
mkHtmlTable :: BlockTable (Int -> Int -> Html) -> HtmlTable
mkHtmlTable BlockTable (Int -> Int -> Html)
r = BlockTable (Int -> Int -> Html) -> HtmlTable
HtmlTable BlockTable (Int -> Int -> Html)
r

-- We give both infix and nonfix, take your pick.
-- Notice that there is no concept of a row/column
-- of zero items.

(</>),above,(<->),beside :: (HTMLTABLE ht1,HTMLTABLE ht2)
                       => ht1 -> ht2 -> HtmlTable
above :: forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
above   ht1
a ht2
b = (BlockTable (Int -> Int -> Html)
 -> BlockTable (Int -> Int -> Html)
 -> BlockTable (Int -> Int -> Html))
-> HtmlTable -> HtmlTable -> HtmlTable
combine BlockTable (Int -> Int -> Html)
-> BlockTable (Int -> Int -> Html)
-> BlockTable (Int -> Int -> Html)
forall a. BlockTable a -> BlockTable a -> BlockTable a
BT.above (ht1 -> HtmlTable
forall ht. HTMLTABLE ht => ht -> HtmlTable
cell ht1
a) (ht2 -> HtmlTable
forall ht. HTMLTABLE ht => ht -> HtmlTable
cell ht2
b)
</> :: forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
(</>)         = ht1 -> ht2 -> HtmlTable
forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
above
beside :: forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
beside  ht1
a ht2
b = (BlockTable (Int -> Int -> Html)
 -> BlockTable (Int -> Int -> Html)
 -> BlockTable (Int -> Int -> Html))
-> HtmlTable -> HtmlTable -> HtmlTable
combine BlockTable (Int -> Int -> Html)
-> BlockTable (Int -> Int -> Html)
-> BlockTable (Int -> Int -> Html)
forall a. BlockTable a -> BlockTable a -> BlockTable a
BT.beside (ht1 -> HtmlTable
forall ht. HTMLTABLE ht => ht -> HtmlTable
cell ht1
a) (ht2 -> HtmlTable
forall ht. HTMLTABLE ht => ht -> HtmlTable
cell ht2
b)
<-> :: forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
(<->) = ht1 -> ht2 -> HtmlTable
forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
beside

combine :: (BT.BlockTable (Int -> Int -> Html) ->
            BT.BlockTable (Int -> Int -> Html) ->
            BT.BlockTable (Int -> Int -> Html))
        -> HtmlTable
        -> HtmlTable
        -> HtmlTable
combine :: (BlockTable (Int -> Int -> Html)
 -> BlockTable (Int -> Int -> Html)
 -> BlockTable (Int -> Int -> Html))
-> HtmlTable -> HtmlTable -> HtmlTable
combine BlockTable (Int -> Int -> Html)
-> BlockTable (Int -> Int -> Html)
-> BlockTable (Int -> Int -> Html)
fn (HtmlTable BlockTable (Int -> Int -> Html)
a) (HtmlTable BlockTable (Int -> Int -> Html)
b) = BlockTable (Int -> Int -> Html) -> HtmlTable
mkHtmlTable (BlockTable (Int -> Int -> Html)
a BlockTable (Int -> Int -> Html)
-> BlockTable (Int -> Int -> Html)
-> BlockTable (Int -> Int -> Html)
`fn` BlockTable (Int -> Int -> Html)
b)

-- Both aboves and besides presume a non-empty list.
-- here is no concept of a empty row or column in these
-- table combinators.

aboves :: (HTMLTABLE ht) => [ht] -> HtmlTable
aboves :: forall ht. HTMLTABLE ht => [ht] -> HtmlTable
aboves []  = [Char] -> HtmlTable
forall a. HasCallStack => [Char] -> a
error [Char]
"aboves []"
aboves [ht]
xs  = (HtmlTable -> HtmlTable -> HtmlTable) -> [HtmlTable] -> HtmlTable
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 HtmlTable -> HtmlTable -> HtmlTable
forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
(</>) ((ht -> HtmlTable) -> [ht] -> [HtmlTable]
forall a b. (a -> b) -> [a] -> [b]
map ht -> HtmlTable
forall ht. HTMLTABLE ht => ht -> HtmlTable
cell [ht]
xs)

besides :: (HTMLTABLE ht) => [ht] -> HtmlTable
besides :: forall ht. HTMLTABLE ht => [ht] -> HtmlTable
besides [] = [Char] -> HtmlTable
forall a. HasCallStack => [Char] -> a
error [Char]
"besides []"
besides [ht]
xs = (HtmlTable -> HtmlTable -> HtmlTable) -> [HtmlTable] -> HtmlTable
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 HtmlTable -> HtmlTable -> HtmlTable
forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
(<->) ((ht -> HtmlTable) -> [ht] -> [HtmlTable]
forall a b. (a -> b) -> [a] -> [b]
map ht -> HtmlTable
forall ht. HTMLTABLE ht => ht -> HtmlTable
cell [ht]
xs)

-- | renderTable takes the HtmlTable, and renders it back into
--   and Html object.
renderTable :: BT.BlockTable (Int -> Int -> Html) -> Html
renderTable :: BlockTable (Int -> Int -> Html) -> Html
renderTable BlockTable (Int -> Int -> Html)
theTable
      = [Html] -> Html
forall a. HTML a => [a] -> Html
concatHtml
          [Html -> Html
tr (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [Int -> Int -> Html
theCell Int
x Int
y | (Int -> Int -> Html
theCell,(Int
x,Int
y)) <- [(Int -> Int -> Html, (Int, Int))]
theRow ]
                      | [(Int -> Int -> Html, (Int, Int))]
theRow <- BlockTable (Int -> Int -> Html)
-> [[(Int -> Int -> Html, (Int, Int))]]
forall a. BlockTable a -> [[(a, (Int, Int))]]
BT.getMatrix BlockTable (Int -> Int -> Html)
theTable]

instance HTML HtmlTable where
      toHtml :: HtmlTable -> Html
toHtml (HtmlTable BlockTable (Int -> Int -> Html)
tab) = BlockTable (Int -> Int -> Html) -> Html
renderTable BlockTable (Int -> Int -> Html)
tab

instance Show HtmlTable where
      showsPrec :: Int -> HtmlTable -> ShowS
showsPrec Int
_ (HtmlTable BlockTable (Int -> Int -> Html)
tab) = Html -> ShowS
forall a. Show a => a -> ShowS
shows (BlockTable (Int -> Int -> Html) -> Html
renderTable BlockTable (Int -> Int -> Html)
tab)


-- | If you can't be bothered with the above, then you
-- can build simple tables with simpleTable.
-- Just provide the attributes for the whole table,
-- attributes for the cells (same for every cell),
-- and a list of lists of cell contents,
-- and this function will build the table for you.
-- It does presume that all the lists are non-empty,
-- and there is at least one list.
--  
-- Different length lists means that the last cell
-- gets padded. If you want more power, then
-- use the system above, or build tables explicitly.
simpleTable :: [HtmlAttr] -> [HtmlAttr] -> [[Html]] -> Html
simpleTable :: [HtmlAttr] -> [HtmlAttr] -> [[Html]] -> Html
simpleTable [HtmlAttr]
attr [HtmlAttr]
cellAttr [[Html]]
lst
      = Html -> Html
table (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [HtmlAttr]
attr 
          (Html -> Html) -> HtmlTable -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<  ([HtmlTable] -> HtmlTable
forall ht. HTMLTABLE ht => [ht] -> HtmlTable
aboves 
              ([HtmlTable] -> HtmlTable)
-> ([[Html]] -> [HtmlTable]) -> [[Html]] -> HtmlTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Html] -> HtmlTable) -> [[Html]] -> [HtmlTable]
forall a b. (a -> b) -> [a] -> [b]
map ([Html] -> HtmlTable
forall ht. HTMLTABLE ht => [ht] -> HtmlTable
besides ([Html] -> HtmlTable) -> ([Html] -> [Html]) -> [Html] -> HtmlTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Html -> Html) -> [Html] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map ((Html -> Html
td (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [HtmlAttr]
cellAttr) (Html -> Html) -> (Html -> Html) -> Html -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Html
forall a. HTML a => a -> Html
toHtml))
              ) [[Html]]
lst