-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Html
-- Copyright   :  (c) Andy Gill and OGI, 1999-2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
-- 
-- Maintainer  :  Andy Gill <andy@galconn.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- An Html combinator library
--
-----------------------------------------------------------------------------

module Text.Html (
      module Text.Html,
      ) where

import qualified Text.Html.BlockTable as BT

infixr 3 </>  -- combining table cells 
infixr 4 <->  -- combining table cells
infixr 2 +++  -- combining Html
infixr 7 <<   -- nesting Html
infixl 8 !    -- adding optional arguments


-- A important property of Html is that all strings inside the
-- structure are already in Html friendly format.
-- For example, use of &gt;,etc.

data HtmlElement
{-
 -    ..just..plain..normal..text... but using &copy; and &amb;, etc.
 -}
      = HtmlString String
{-
 -    <thetag {..attrs..}> ..content.. </thetag>
 -}
      | HtmlTag {                   -- tag with internal markup
              HtmlElement -> [Char]
markupTag      :: String,
              HtmlElement -> [HtmlAttr]
markupAttrs    :: [HtmlAttr],
              HtmlElement -> Html
markupContent  :: Html
              }

{- These are the index-value pairs.
 - The empty string is a synonym for tags with no arguments.
 - (not strictly HTML, but anyway).
 -}


data HtmlAttr = HtmlAttr String String


newtype Html = Html { Html -> [HtmlElement]
getHtmlElements :: [HtmlElement] }

-- Read MARKUP as the class of things that can be validly rendered
-- inside MARKUP tag brackets. So this can be one or more Html's,
-- or a String, for example.

class HTML a where
      toHtml     :: a -> Html
      toHtmlFromList :: [a] -> Html

      toHtmlFromList [a]
xs = [HtmlElement] -> Html
Html ([[HtmlElement]] -> [HtmlElement]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [HtmlElement]
x | (Html [HtmlElement]
x) <- (a -> Html) -> [a] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map a -> Html
forall a. HTML a => a -> Html
toHtml [a]
xs])

instance HTML Html where
      toHtml :: Html -> Html
toHtml Html
a    = Html
a

instance HTML Char where
      toHtml :: Char -> Html
toHtml       Char
a = [Char] -> Html
forall a. HTML a => a -> Html
toHtml [Char
a]
      toHtmlFromList :: [Char] -> Html
toHtmlFromList []  = [HtmlElement] -> Html
Html []
      toHtmlFromList [Char]
str = [HtmlElement] -> Html
Html [[Char] -> HtmlElement
HtmlString ([Char] -> [Char]
stringToHtmlString [Char]
str)]

instance (HTML a) => HTML [a] where
      toHtml :: [a] -> Html
toHtml [a]
xs = [a] -> Html
forall a. HTML a => [a] -> Html
toHtmlFromList [a]
xs

class ADDATTRS a where
      (!) :: a -> [HtmlAttr] -> a

instance (ADDATTRS b) => ADDATTRS (a -> b) where
      a -> b
fn ! :: (a -> b) -> [HtmlAttr] -> a -> b
! [HtmlAttr]
attr = \ a
arg -> a -> b
fn a
arg b -> [HtmlAttr] -> b
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [HtmlAttr]
attr

instance ADDATTRS Html where
      (Html [HtmlElement]
htmls) ! :: Html -> [HtmlAttr] -> Html
! [HtmlAttr]
attr = [HtmlElement] -> Html
Html ((HtmlElement -> HtmlElement) -> [HtmlElement] -> [HtmlElement]
forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> HtmlElement
addAttrs [HtmlElement]
htmls)
        where
              addAttrs :: HtmlElement -> HtmlElement
addAttrs (html :: HtmlElement
html@(HtmlTag { markupAttrs :: HtmlElement -> [HtmlAttr]
markupAttrs = [HtmlAttr]
markupAttrs }) )
                              = HtmlElement
html { markupAttrs = markupAttrs ++ attr }
              addAttrs HtmlElement
html = HtmlElement
html


(<<)            :: (HTML a) => (Html -> b) -> a        -> b
Html -> b
fn << :: forall a b. HTML a => (Html -> b) -> a -> b
<< a
arg = Html -> b
fn (a -> Html
forall a. HTML a => a -> Html
toHtml a
arg)


concatHtml :: (HTML a) => [a] -> Html
concatHtml :: forall a. HTML a => [a] -> Html
concatHtml [a]
as = [HtmlElement] -> Html
Html ([[HtmlElement]] -> [HtmlElement]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((a -> [HtmlElement]) -> [a] -> [[HtmlElement]]
forall a b. (a -> b) -> [a] -> [b]
map (Html -> [HtmlElement]
getHtmlElements(Html -> [HtmlElement]) -> (a -> Html) -> a -> [HtmlElement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> Html
forall a. HTML a => a -> Html
toHtml) [a]
as))

(+++) :: (HTML a,HTML b) => a -> b -> Html
a
a +++ :: forall a b. (HTML a, HTML b) => a -> b -> Html
+++ b
b = [HtmlElement] -> Html
Html (Html -> [HtmlElement]
getHtmlElements (a -> Html
forall a. HTML a => a -> Html
toHtml a
a) [HtmlElement] -> [HtmlElement] -> [HtmlElement]
forall a. [a] -> [a] -> [a]
++ Html -> [HtmlElement]
getHtmlElements (b -> Html
forall a. HTML a => a -> Html
toHtml b
b))

noHtml :: Html
noHtml :: Html
noHtml = [HtmlElement] -> Html
Html []


isNoHtml :: Html -> Bool
isNoHtml (Html [HtmlElement]
xs) = [HtmlElement] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HtmlElement]
xs


tag  :: String -> Html -> Html
tag :: [Char] -> Html -> Html
tag [Char]
str       Html
htmls = [HtmlElement] -> Html
Html [
      HtmlTag {
              markupTag :: [Char]
markupTag = [Char]
str,
              markupAttrs :: [HtmlAttr]
markupAttrs = [],
              markupContent :: Html
markupContent = Html
htmls }]

itag :: String -> Html
itag :: [Char] -> Html
itag [Char]
str = [Char] -> Html -> Html
tag [Char]
str Html
noHtml

emptyAttr :: String -> HtmlAttr
emptyAttr :: [Char] -> HtmlAttr
emptyAttr [Char]
s = [Char] -> [Char] -> HtmlAttr
HtmlAttr [Char]
s [Char]
""

intAttr :: String -> Int -> HtmlAttr
intAttr :: [Char] -> Int -> HtmlAttr
intAttr [Char]
s Int
i = [Char] -> [Char] -> HtmlAttr
HtmlAttr [Char]
s (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i)

strAttr :: String -> String -> HtmlAttr
strAttr :: [Char] -> [Char] -> HtmlAttr
strAttr [Char]
s [Char]
t = [Char] -> [Char] -> HtmlAttr
HtmlAttr [Char]
s [Char]
t


{-
foldHtml :: (String -> [HtmlAttr] -> [a] -> a) 
      -> (String -> a)
      -> Html
      -> a
foldHtml f g (HtmlTag str attr fmls) 
      = f str attr (map (foldHtml f g) fmls) 
foldHtml f g (HtmlString  str)           
      = g str

-}
-- Processing Strings into Html friendly things.
-- This converts a String to a Html String.
stringToHtmlString :: String -> String
stringToHtmlString :: [Char] -> [Char]
stringToHtmlString = (Char -> [Char]) -> [Char] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> [Char]
fixChar
    where
      fixChar :: Char -> [Char]
fixChar Char
'<' = [Char]
"&lt;"
      fixChar Char
'>' = [Char]
"&gt;"
      fixChar Char
'&' = [Char]
"&amp;"
      fixChar Char
'"' = [Char]
"&quot;"
      fixChar Char
c   = [Char
c]               

-- ---------------------------------------------------------------------------
-- Classes

instance Show Html where
      showsPrec :: Int -> Html -> [Char] -> [Char]
showsPrec Int
_ Html
html = [Char] -> [Char] -> [Char]
showString (Html -> [Char]
forall html. HTML html => html -> [Char]
prettyHtml Html
html)
      showList :: [Html] -> [Char] -> [Char]
showList [Html]
htmls   = [Char] -> [Char] -> [Char]
showString ([[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Html -> [Char]) -> [Html] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Html -> [Char]
forall a. Show a => a -> [Char]
show [Html]
htmls))

instance Show HtmlAttr where
      showsPrec :: Int -> HtmlAttr -> [Char] -> [Char]
showsPrec Int
_ (HtmlAttr [Char]
str [Char]
val) = 
              [Char] -> [Char] -> [Char]
showString [Char]
str ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              [Char] -> [Char] -> [Char]
showString [Char]
"=" ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              [Char] -> [Char] -> [Char]
forall a. Show a => a -> [Char] -> [Char]
shows [Char]
val


-- ---------------------------------------------------------------------------
-- Data types

type URL = String

-- ---------------------------------------------------------------------------
-- Basic primitives

-- This is not processed for special chars. 
-- use stringToHtml or lineToHtml instead, for user strings, 
-- because they  understand special chars, like '<'.

primHtml      :: String                                -> Html
primHtml :: [Char] -> Html
primHtml [Char]
x    = [HtmlElement] -> Html
Html [[Char] -> HtmlElement
HtmlString [Char]
x]

-- ---------------------------------------------------------------------------
-- Basic Combinators

stringToHtml          :: String                       -> Html
stringToHtml :: [Char] -> Html
stringToHtml = [Char] -> Html
primHtml ([Char] -> Html) -> ([Char] -> [Char]) -> [Char] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
stringToHtmlString 

-- This converts a string, but keeps spaces as non-line-breakable

lineToHtml            :: String                       -> Html
lineToHtml :: [Char] -> Html
lineToHtml = [Char] -> Html
primHtml ([Char] -> Html) -> ([Char] -> [Char]) -> [Char] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> [Char]) -> [Char] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> [Char]
htmlizeChar2 ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
stringToHtmlString 
   where 
      htmlizeChar2 :: Char -> [Char]
htmlizeChar2 Char
' ' = [Char]
"&nbsp;"
      htmlizeChar2 Char
c   = [Char
c]

-- ---------------------------------------------------------------------------
-- Html Constructors

-- (automatically generated)

address             :: Html -> Html
anchor              :: Html -> Html
applet              :: Html -> Html
area                ::         Html
basefont            ::         Html
big                 :: Html -> Html
blockquote          :: Html -> Html
body                :: Html -> Html
bold                :: Html -> Html
br                  ::         Html
caption             :: Html -> Html
center              :: Html -> Html
cite                :: Html -> Html
ddef                :: Html -> Html
define              :: Html -> Html
dlist               :: Html -> Html
dterm               :: Html -> Html
emphasize           :: Html -> Html
fieldset            :: Html -> Html
font                :: Html -> Html
form                :: Html -> Html
frame               :: Html -> Html
frameset            :: Html -> Html
h1                  :: Html -> Html
h2                  :: Html -> Html
h3                  :: Html -> Html
h4                  :: Html -> Html
h5                  :: Html -> Html
h6                  :: Html -> Html
header              :: Html -> Html
hr                  ::         Html
image               ::         Html
input               ::         Html
italics             :: Html -> Html
keyboard            :: Html -> Html
legend              :: Html -> Html
li                  :: Html -> Html
meta                ::         Html
noframes            :: Html -> Html
olist               :: Html -> Html
option              :: Html -> Html
paragraph           :: Html -> Html
param               ::         Html
pre                 :: Html -> Html
sample              :: Html -> Html
select              :: Html -> Html
small               :: Html -> Html
strong              :: Html -> Html
style               :: Html -> Html
sub                 :: Html -> Html
sup                 :: Html -> Html
table               :: Html -> Html
td                  :: Html -> Html
textarea            :: Html -> Html
th                  :: Html -> Html
thebase             ::         Html
thecode             :: Html -> Html
thediv              :: Html -> Html
thehtml             :: Html -> Html
thelink             :: Html -> Html
themap              :: Html -> Html
thespan             :: Html -> Html
thetitle            :: Html -> Html
tr                  :: Html -> Html
tt                  :: Html -> Html
ulist               :: Html -> Html
underline           :: Html -> Html
variable            :: Html -> Html

address :: Html -> Html
address             =  [Char] -> Html -> Html
tag [Char]
"ADDRESS"
anchor :: Html -> Html
anchor              =  [Char] -> Html -> Html
tag [Char]
"A"
applet :: Html -> Html
applet              =  [Char] -> Html -> Html
tag [Char]
"APPLET"
area :: Html
area                = [Char] -> Html
itag [Char]
"AREA"
basefont :: Html
basefont            = [Char] -> Html
itag [Char]
"BASEFONT"
big :: Html -> Html
big                 =  [Char] -> Html -> Html
tag [Char]
"BIG"
blockquote :: Html -> Html
blockquote          =  [Char] -> Html -> Html
tag [Char]
"BLOCKQUOTE"
body :: Html -> Html
body                =  [Char] -> Html -> Html
tag [Char]
"BODY"
bold :: Html -> Html
bold                =  [Char] -> Html -> Html
tag [Char]
"B"
br :: Html
br                  = [Char] -> Html
itag [Char]
"BR"
caption :: Html -> Html
caption             =  [Char] -> Html -> Html
tag [Char]
"CAPTION"
center :: Html -> Html
center              =  [Char] -> Html -> Html
tag [Char]
"CENTER"
cite :: Html -> Html
cite                =  [Char] -> Html -> Html
tag [Char]
"CITE"
ddef :: Html -> Html
ddef                =  [Char] -> Html -> Html
tag [Char]
"DD"
define :: Html -> Html
define              =  [Char] -> Html -> Html
tag [Char]
"DFN"
dlist :: Html -> Html
dlist               =  [Char] -> Html -> Html
tag [Char]
"DL"
dterm :: Html -> Html
dterm               =  [Char] -> Html -> Html
tag [Char]
"DT"
emphasize :: Html -> Html
emphasize           =  [Char] -> Html -> Html
tag [Char]
"EM"
fieldset :: Html -> Html
fieldset            =  [Char] -> Html -> Html
tag [Char]
"FIELDSET"
font :: Html -> Html
font                =  [Char] -> Html -> Html
tag [Char]
"FONT"
form :: Html -> Html
form                =  [Char] -> Html -> Html
tag [Char]
"FORM"
frame :: Html -> Html
frame               =  [Char] -> Html -> Html
tag [Char]
"FRAME"
frameset :: Html -> Html
frameset            =  [Char] -> Html -> Html
tag [Char]
"FRAMESET"
h1 :: Html -> Html
h1                  =  [Char] -> Html -> Html
tag [Char]
"H1"
h2 :: Html -> Html
h2                  =  [Char] -> Html -> Html
tag [Char]
"H2"
h3 :: Html -> Html
h3                  =  [Char] -> Html -> Html
tag [Char]
"H3"
h4 :: Html -> Html
h4                  =  [Char] -> Html -> Html
tag [Char]
"H4"
h5 :: Html -> Html
h5                  =  [Char] -> Html -> Html
tag [Char]
"H5"
h6 :: Html -> Html
h6                  =  [Char] -> Html -> Html
tag [Char]
"H6"
header :: Html -> Html
header              =  [Char] -> Html -> Html
tag [Char]
"HEAD"
hr :: Html
hr                  = [Char] -> Html
itag [Char]
"HR"
image :: Html
image               = [Char] -> Html
itag [Char]
"IMG"
input :: Html
input               = [Char] -> Html
itag [Char]
"INPUT"
italics :: Html -> Html
italics             =  [Char] -> Html -> Html
tag [Char]
"I"
keyboard :: Html -> Html
keyboard            =  [Char] -> Html -> Html
tag [Char]
"KBD"
legend :: Html -> Html
legend              =  [Char] -> Html -> Html
tag [Char]
"LEGEND"
li :: Html -> Html
li                  =  [Char] -> Html -> Html
tag [Char]
"LI"
meta :: Html
meta                = [Char] -> Html
itag [Char]
"META"
noframes :: Html -> Html
noframes            =  [Char] -> Html -> Html
tag [Char]
"NOFRAMES"
olist :: Html -> Html
olist               =  [Char] -> Html -> Html
tag [Char]
"OL"
option :: Html -> Html
option              =  [Char] -> Html -> Html
tag [Char]
"OPTION"
paragraph :: Html -> Html
paragraph           =  [Char] -> Html -> Html
tag [Char]
"P"
param :: Html
param               = [Char] -> Html
itag [Char]
"PARAM"
pre :: Html -> Html
pre                 =  [Char] -> Html -> Html
tag [Char]
"PRE"
sample :: Html -> Html
sample              =  [Char] -> Html -> Html
tag [Char]
"SAMP"
select :: Html -> Html
select              =  [Char] -> Html -> Html
tag [Char]
"SELECT"
small :: Html -> Html
small               =  [Char] -> Html -> Html
tag [Char]
"SMALL"
strong :: Html -> Html
strong              =  [Char] -> Html -> Html
tag [Char]
"STRONG"
style :: Html -> Html
style               =  [Char] -> Html -> Html
tag [Char]
"STYLE"
sub :: Html -> Html
sub                 =  [Char] -> Html -> Html
tag [Char]
"SUB"
sup :: Html -> Html
sup                 =  [Char] -> Html -> Html
tag [Char]
"SUP"
table :: Html -> Html
table               =  [Char] -> Html -> Html
tag [Char]
"TABLE"
td :: Html -> Html
td                  =  [Char] -> Html -> Html
tag [Char]
"TD"
textarea :: Html -> Html
textarea            =  [Char] -> Html -> Html
tag [Char]
"TEXTAREA"
th :: Html -> Html
th                  =  [Char] -> Html -> Html
tag [Char]
"TH"
thebase :: Html
thebase             = [Char] -> Html
itag [Char]
"BASE"
thecode :: Html -> Html
thecode             =  [Char] -> Html -> Html
tag [Char]
"CODE"
thediv :: Html -> Html
thediv              =  [Char] -> Html -> Html
tag [Char]
"DIV"
thehtml :: Html -> Html
thehtml             =  [Char] -> Html -> Html
tag [Char]
"HTML"
thelink :: Html -> Html
thelink             =  [Char] -> Html -> Html
tag [Char]
"LINK"
themap :: Html -> Html
themap              =  [Char] -> Html -> Html
tag [Char]
"MAP"
thespan :: Html -> Html
thespan             =  [Char] -> Html -> Html
tag [Char]
"SPAN"
thetitle :: Html -> Html
thetitle            =  [Char] -> Html -> Html
tag [Char]
"TITLE"
tr :: Html -> Html
tr                  =  [Char] -> Html -> Html
tag [Char]
"TR"
tt :: Html -> Html
tt                  =  [Char] -> Html -> Html
tag [Char]
"TT"
ulist :: Html -> Html
ulist               =  [Char] -> Html -> Html
tag [Char]
"UL"
underline :: Html -> Html
underline           =  [Char] -> Html -> Html
tag [Char]
"U"
variable :: Html -> Html
variable            =  [Char] -> Html -> Html
tag [Char]
"VAR"

-- ---------------------------------------------------------------------------
-- Html Attributes

-- (automatically generated)

action              :: String -> HtmlAttr
align               :: String -> HtmlAttr
alink               :: String -> HtmlAttr
alt                 :: String -> HtmlAttr
altcode             :: String -> HtmlAttr
archive             :: String -> HtmlAttr
background          :: String -> HtmlAttr
base                :: String -> HtmlAttr
bgcolor             :: String -> HtmlAttr
border              :: Int    -> HtmlAttr
bordercolor         :: String -> HtmlAttr
cellpadding         :: Int    -> HtmlAttr
cellspacing         :: Int    -> HtmlAttr
checked             ::           HtmlAttr
clear               :: String -> HtmlAttr
code                :: String -> HtmlAttr
codebase            :: String -> HtmlAttr
color               :: String -> HtmlAttr
cols                :: String -> HtmlAttr
colspan             :: Int    -> HtmlAttr
compact             ::           HtmlAttr
content             :: String -> HtmlAttr
coords              :: String -> HtmlAttr
enctype             :: String -> HtmlAttr
face                :: String -> HtmlAttr
frameborder         :: Int    -> HtmlAttr
height              :: Int    -> HtmlAttr
href                :: String -> HtmlAttr
hspace              :: Int    -> HtmlAttr
httpequiv           :: String -> HtmlAttr
identifier          :: String -> HtmlAttr
ismap               ::           HtmlAttr
lang                :: String -> HtmlAttr
link                :: String -> HtmlAttr
marginheight        :: Int    -> HtmlAttr
marginwidth         :: Int    -> HtmlAttr
maxlength           :: Int    -> HtmlAttr
method              :: String -> HtmlAttr
multiple            ::           HtmlAttr
name                :: String -> HtmlAttr
nohref              ::           HtmlAttr
noresize            ::           HtmlAttr
noshade             ::           HtmlAttr
nowrap              ::           HtmlAttr
rel                 :: String -> HtmlAttr
rev                 :: String -> HtmlAttr
rows                :: String -> HtmlAttr
rowspan             :: Int    -> HtmlAttr
rules               :: String -> HtmlAttr
scrolling           :: String -> HtmlAttr
selected            ::           HtmlAttr
shape               :: String -> HtmlAttr
size                :: String -> HtmlAttr
src                 :: String -> HtmlAttr
start               :: Int    -> HtmlAttr
target              :: String -> HtmlAttr
text                :: String -> HtmlAttr
theclass            :: String -> HtmlAttr
thestyle            :: String -> HtmlAttr
thetype             :: String -> HtmlAttr
title               :: String -> HtmlAttr
usemap              :: String -> HtmlAttr
valign              :: String -> HtmlAttr
value               :: String -> HtmlAttr
version             :: String -> HtmlAttr
vlink               :: String -> HtmlAttr
vspace              :: Int    -> HtmlAttr
width               :: String -> HtmlAttr

action :: [Char] -> HtmlAttr
action              =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"ACTION"
align :: [Char] -> HtmlAttr
align               =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"ALIGN"
alink :: [Char] -> HtmlAttr
alink               =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"ALINK"
alt :: [Char] -> HtmlAttr
alt                 =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"ALT"
altcode :: [Char] -> HtmlAttr
altcode             =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"ALTCODE"
archive :: [Char] -> HtmlAttr
archive             =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"ARCHIVE"
background :: [Char] -> HtmlAttr
background          =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"BACKGROUND"
base :: [Char] -> HtmlAttr
base                =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"BASE"
bgcolor :: [Char] -> HtmlAttr
bgcolor             =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"BGCOLOR"
border :: Int -> HtmlAttr
border              =   [Char] -> Int -> HtmlAttr
intAttr [Char]
"BORDER"
bordercolor :: [Char] -> HtmlAttr
bordercolor         =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"BORDERCOLOR"
cellpadding :: Int -> HtmlAttr
cellpadding         =   [Char] -> Int -> HtmlAttr
intAttr [Char]
"CELLPADDING"
cellspacing :: Int -> HtmlAttr
cellspacing         =   [Char] -> Int -> HtmlAttr
intAttr [Char]
"CELLSPACING"
checked :: HtmlAttr
checked             = [Char] -> HtmlAttr
emptyAttr [Char]
"CHECKED"
clear :: [Char] -> HtmlAttr
clear               =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"CLEAR"
code :: [Char] -> HtmlAttr
code                =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"CODE"
codebase :: [Char] -> HtmlAttr
codebase            =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"CODEBASE"
color :: [Char] -> HtmlAttr
color               =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"COLOR"
cols :: [Char] -> HtmlAttr
cols                =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"COLS"
colspan :: Int -> HtmlAttr
colspan             =   [Char] -> Int -> HtmlAttr
intAttr [Char]
"COLSPAN"
compact :: HtmlAttr
compact             = [Char] -> HtmlAttr
emptyAttr [Char]
"COMPACT"
content :: [Char] -> HtmlAttr
content             =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"CONTENT"
coords :: [Char] -> HtmlAttr
coords              =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"COORDS"
enctype :: [Char] -> HtmlAttr
enctype             =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"ENCTYPE"
face :: [Char] -> HtmlAttr
face                =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"FACE"
frameborder :: Int -> HtmlAttr
frameborder         =   [Char] -> Int -> HtmlAttr
intAttr [Char]
"FRAMEBORDER"
height :: Int -> HtmlAttr
height              =   [Char] -> Int -> HtmlAttr
intAttr [Char]
"HEIGHT"
href :: [Char] -> HtmlAttr
href                =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"HREF"
hspace :: Int -> HtmlAttr
hspace              =   [Char] -> Int -> HtmlAttr
intAttr [Char]
"HSPACE"
httpequiv :: [Char] -> HtmlAttr
httpequiv           =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"HTTP-EQUIV"
identifier :: [Char] -> HtmlAttr
identifier          =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"ID"
ismap :: HtmlAttr
ismap               = [Char] -> HtmlAttr
emptyAttr [Char]
"ISMAP"
lang :: [Char] -> HtmlAttr
lang                =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"LANG"
link :: [Char] -> HtmlAttr
link                =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"LINK"
marginheight :: Int -> HtmlAttr
marginheight        =   [Char] -> Int -> HtmlAttr
intAttr [Char]
"MARGINHEIGHT"
marginwidth :: Int -> HtmlAttr
marginwidth         =   [Char] -> Int -> HtmlAttr
intAttr [Char]
"MARGINWIDTH"
maxlength :: Int -> HtmlAttr
maxlength           =   [Char] -> Int -> HtmlAttr
intAttr [Char]
"MAXLENGTH"
method :: [Char] -> HtmlAttr
method              =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"METHOD"
multiple :: HtmlAttr
multiple            = [Char] -> HtmlAttr
emptyAttr [Char]
"MULTIPLE"
name :: [Char] -> HtmlAttr
name                =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"NAME"
nohref :: HtmlAttr
nohref              = [Char] -> HtmlAttr
emptyAttr [Char]
"NOHREF"
noresize :: HtmlAttr
noresize            = [Char] -> HtmlAttr
emptyAttr [Char]
"NORESIZE"
noshade :: HtmlAttr
noshade             = [Char] -> HtmlAttr
emptyAttr [Char]
"NOSHADE"
nowrap :: HtmlAttr
nowrap              = [Char] -> HtmlAttr
emptyAttr [Char]
"NOWRAP"
rel :: [Char] -> HtmlAttr
rel                 =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"REL"
rev :: [Char] -> HtmlAttr
rev                 =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"REV"
rows :: [Char] -> HtmlAttr
rows                =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"ROWS"
rowspan :: Int -> HtmlAttr
rowspan             =   [Char] -> Int -> HtmlAttr
intAttr [Char]
"ROWSPAN"
rules :: [Char] -> HtmlAttr
rules               =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"RULES"
scrolling :: [Char] -> HtmlAttr
scrolling           =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"SCROLLING"
selected :: HtmlAttr
selected            = [Char] -> HtmlAttr
emptyAttr [Char]
"SELECTED"
shape :: [Char] -> HtmlAttr
shape               =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"SHAPE"
size :: [Char] -> HtmlAttr
size                =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"SIZE"
src :: [Char] -> HtmlAttr
src                 =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"SRC"
start :: Int -> HtmlAttr
start               =   [Char] -> Int -> HtmlAttr
intAttr [Char]
"START"
target :: [Char] -> HtmlAttr
target              =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"TARGET"
text :: [Char] -> HtmlAttr
text                =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"TEXT"
theclass :: [Char] -> HtmlAttr
theclass            =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"CLASS"
thestyle :: [Char] -> HtmlAttr
thestyle            =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"STYLE"
thetype :: [Char] -> HtmlAttr
thetype             =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"TYPE"
title :: [Char] -> HtmlAttr
title               =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"TITLE"
usemap :: [Char] -> HtmlAttr
usemap              =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"USEMAP"
valign :: [Char] -> HtmlAttr
valign              =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"VALIGN"
value :: [Char] -> HtmlAttr
value               =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"VALUE"
version :: [Char] -> HtmlAttr
version             =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"VERSION"
vlink :: [Char] -> HtmlAttr
vlink               =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"VLINK"
vspace :: Int -> HtmlAttr
vspace              =   [Char] -> Int -> HtmlAttr
intAttr [Char]
"VSPACE"
width :: [Char] -> HtmlAttr
width               =   [Char] -> [Char] -> HtmlAttr
strAttr [Char]
"WIDTH"

-- ---------------------------------------------------------------------------
-- Html Constructors

-- (automatically generated)

validHtmlTags :: [String]
validHtmlTags :: [[Char]]
validHtmlTags = [
      [Char]
"ADDRESS",
      [Char]
"A",
      [Char]
"APPLET",
      [Char]
"BIG",
      [Char]
"BLOCKQUOTE",
      [Char]
"BODY",
      [Char]
"B",
      [Char]
"CAPTION",
      [Char]
"CENTER",
      [Char]
"CITE",
      [Char]
"DD",
      [Char]
"DFN",
      [Char]
"DL",
      [Char]
"DT",
      [Char]
"EM",
      [Char]
"FIELDSET",
      [Char]
"FONT",
      [Char]
"FORM",
      [Char]
"FRAME",
      [Char]
"FRAMESET",
      [Char]
"H1",
      [Char]
"H2",
      [Char]
"H3",
      [Char]
"H4",
      [Char]
"H5",
      [Char]
"H6",
      [Char]
"HEAD",
      [Char]
"I",
      [Char]
"KBD",
      [Char]
"LEGEND",
      [Char]
"LI",
      [Char]
"NOFRAMES",
      [Char]
"OL",
      [Char]
"OPTION",
      [Char]
"P",
      [Char]
"PRE",
      [Char]
"SAMP",
      [Char]
"SELECT",
      [Char]
"SMALL",
      [Char]
"STRONG",
      [Char]
"STYLE",
      [Char]
"SUB",
      [Char]
"SUP",
      [Char]
"TABLE",
      [Char]
"TD",
      [Char]
"TEXTAREA",
      [Char]
"TH",
      [Char]
"CODE",
      [Char]
"DIV",
      [Char]
"HTML",
      [Char]
"LINK",
      [Char]
"MAP",
      [Char]
"TITLE",
      [Char]
"TR",
      [Char]
"TT",
      [Char]
"UL",
      [Char]
"U",
      [Char]
"VAR"]

validHtmlITags :: [String]
validHtmlITags :: [[Char]]
validHtmlITags = [
      [Char]
"AREA",
      [Char]
"BASEFONT",
      [Char]
"BR",
      [Char]
"HR",
      [Char]
"IMG",
      [Char]
"INPUT",
      [Char]
"META",
      [Char]
"PARAM",
      [Char]
"BASE"]

validHtmlAttrs :: [String]
validHtmlAttrs :: [[Char]]
validHtmlAttrs = [
      [Char]
"ACTION",
      [Char]
"ALIGN",
      [Char]
"ALINK",
      [Char]
"ALT",
      [Char]
"ALTCODE",
      [Char]
"ARCHIVE",
      [Char]
"BACKGROUND",
      [Char]
"BASE",
      [Char]
"BGCOLOR",
      [Char]
"BORDER",
      [Char]
"BORDERCOLOR",
      [Char]
"CELLPADDING",
      [Char]
"CELLSPACING",
      [Char]
"CHECKED",
      [Char]
"CLEAR",
      [Char]
"CODE",
      [Char]
"CODEBASE",
      [Char]
"COLOR",
      [Char]
"COLS",
      [Char]
"COLSPAN",
      [Char]
"COMPACT",
      [Char]
"CONTENT",
      [Char]
"COORDS",
      [Char]
"ENCTYPE",
      [Char]
"FACE",
      [Char]
"FRAMEBORDER",
      [Char]
"HEIGHT",
      [Char]
"HREF",
      [Char]
"HSPACE",
      [Char]
"HTTP-EQUIV",
      [Char]
"ID",
      [Char]
"ISMAP",
      [Char]
"LANG",
      [Char]
"LINK",
      [Char]
"MARGINHEIGHT",
      [Char]
"MARGINWIDTH",
      [Char]
"MAXLENGTH",
      [Char]
"METHOD",
      [Char]
"MULTIPLE",
      [Char]
"NAME",
      [Char]
"NOHREF",
      [Char]
"NORESIZE",
      [Char]
"NOSHADE",
      [Char]
"NOWRAP",
      [Char]
"REL",
      [Char]
"REV",
      [Char]
"ROWS",
      [Char]
"ROWSPAN",
      [Char]
"RULES",
      [Char]
"SCROLLING",
      [Char]
"SELECTED",
      [Char]
"SHAPE",
      [Char]
"SIZE",
      [Char]
"SRC",
      [Char]
"START",
      [Char]
"TARGET",
      [Char]
"TEXT",
      [Char]
"CLASS",
      [Char]
"STYLE",
      [Char]
"TYPE",
      [Char]
"TITLE",
      [Char]
"USEMAP",
      [Char]
"VALIGN",
      [Char]
"VALUE",
      [Char]
"VERSION",
      [Char]
"VLINK",
      [Char]
"VSPACE",
      [Char]
"WIDTH"]

-- ---------------------------------------------------------------------------
-- Html colors

aqua          :: String
black         :: String
blue          :: String
fuchsia       :: String
gray          :: String
green         :: String
lime          :: String
maroon        :: String
navy          :: String
olive         :: String
purple        :: String
red           :: String
silver        :: String
teal          :: String
yellow        :: String
white         :: String

aqua :: [Char]
aqua          = [Char]
"aqua"
black :: [Char]
black         = [Char]
"black"
blue :: [Char]
blue          = [Char]
"blue"
fuchsia :: [Char]
fuchsia       = [Char]
"fuchsia"
gray :: [Char]
gray          = [Char]
"gray"
green :: [Char]
green         = [Char]
"green"
lime :: [Char]
lime          = [Char]
"lime"
maroon :: [Char]
maroon        = [Char]
"maroon"
navy :: [Char]
navy          = [Char]
"navy"
olive :: [Char]
olive         = [Char]
"olive"
purple :: [Char]
purple        = [Char]
"purple"
red :: [Char]
red           = [Char]
"red"
silver :: [Char]
silver        = [Char]
"silver"
teal :: [Char]
teal          = [Char]
"teal"
yellow :: [Char]
yellow        = [Char]
"yellow"
white :: [Char]
white         = [Char]
"white"

-- ---------------------------------------------------------------------------
-- Basic Combinators

linesToHtml :: [String]       -> Html

linesToHtml :: [[Char]] -> Html
linesToHtml []     = Html
noHtml
linesToHtml ([Char]
x:[]) = [Char] -> Html
lineToHtml [Char]
x
linesToHtml ([Char]
x:[[Char]]
xs) = [Char] -> Html
lineToHtml [Char]
x Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ Html
br Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++ [[Char]] -> Html
linesToHtml [[Char]]
xs


-- ---------------------------------------------------------------------------
-- Html abbriviations

primHtmlChar  :: String -> Html
copyright     :: Html
spaceHtml     :: Html
bullet        :: Html
p             :: Html -> Html

primHtmlChar :: [Char] -> Html
primHtmlChar  = \ [Char]
x -> [Char] -> Html
primHtml ([Char]
"&" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
";")
copyright :: Html
copyright     = [Char] -> Html
primHtmlChar [Char]
"copy"
spaceHtml :: Html
spaceHtml     = [Char] -> Html
primHtmlChar [Char]
"nbsp"
bullet :: Html
bullet        = [Char] -> Html
primHtmlChar [Char]
"#149"

p :: Html -> Html
p             = Html -> Html
paragraph

-- ---------------------------------------------------------------------------
-- Html 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
fn [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
-- \pre{
-- 	   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))


(</>),above,(<->),beside :: (HTMLTABLE ht1,HTMLTABLE ht2)
                       => ht1 -> ht2 -> HtmlTable
aboves,besides                 :: (HTMLTABLE ht) => [ht] -> HtmlTable
simpleTable            :: [HtmlAttr] -> [HtmlAttr] -> [[Html]] -> 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 :: 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 :: (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 :: 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 :: 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 -> [Char] -> [Char]
showsPrec Int
_ (HtmlTable BlockTable (Int -> Int -> Html)
tab) = Html -> [Char] -> [Char]
forall a. Show a => a -> [Char] -> [Char]
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]
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


-- ---------------------------------------------------------------------------
-- Tree Displaying Combinators
 
-- The basic idea is you render your structure in the form
-- of this tree, and then use treeHtml to turn it into a Html
-- object with the structure explicit.

data HtmlTree
      = HtmlLeaf Html
      | HtmlNode Html [HtmlTree] Html

treeHtml :: [String] -> HtmlTree -> Html
treeHtml :: [[Char]] -> HtmlTree -> Html
treeHtml [[Char]]
colors HtmlTree
h = Html -> Html
table (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [
                    Int -> HtmlAttr
border Int
0,
                    Int -> HtmlAttr
cellpadding Int
0,
                    Int -> HtmlAttr
cellspacing Int
2] (Html -> Html) -> HtmlTable -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [[Char]] -> HtmlTree -> HtmlTable
treeHtml' [[Char]]
colors HtmlTree
h
     where
      manycolors :: [a] -> [[a]]
manycolors = (a -> [a] -> [a]) -> [a] -> [a] -> [[a]]
forall a b. (a -> b -> b) -> b -> [a] -> [b]
scanr (:) []

      treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable
      treeHtmls :: [[[Char]]] -> [HtmlTree] -> HtmlTable
treeHtmls [[[Char]]]
c [HtmlTree]
ts = [HtmlTable] -> HtmlTable
forall ht. HTMLTABLE ht => [ht] -> HtmlTable
aboves (([[Char]] -> HtmlTree -> HtmlTable)
-> [[[Char]]] -> [HtmlTree] -> [HtmlTable]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [[Char]] -> HtmlTree -> HtmlTable
treeHtml' [[[Char]]]
c [HtmlTree]
ts)

      treeHtml' :: [String] -> HtmlTree -> HtmlTable
      treeHtml' :: [[Char]] -> HtmlTree -> HtmlTable
treeHtml' ([Char]
c:[[Char]]
_) (HtmlLeaf Html
leaf) = Html -> HtmlTable
forall ht. HTMLTABLE ht => ht -> HtmlTable
cell
                                         (Html -> Html
td (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [[Char] -> HtmlAttr
width [Char]
"100%"] 
                                            (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html -> Html
bold  
                                               (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
leaf)
      treeHtml' ([Char]
c:cs :: [[Char]]
cs@([Char]
c2:[[Char]]
_)) (HtmlNode Html
hopen [HtmlTree]
ts Html
hclose) =
          if [HtmlTree] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HtmlTree]
ts Bool -> Bool -> Bool
&& Html -> Bool
isNoHtml Html
hclose
          then
              Html -> HtmlTable
forall ht. HTMLTABLE ht => ht -> HtmlTable
cell Html
hd 
          else if [HtmlTree] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HtmlTree]
ts
          then
              Html
hd Html -> HtmlTable -> HtmlTable
forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
</> Html
bar Html -> Html -> HtmlTable
forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
`beside` (Html -> Html
td (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [[Char] -> HtmlAttr
bgcolor [Char]
c2] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
spaceHtml)
                 HtmlTable -> Html -> HtmlTable
forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
</> Html
tl
          else
              Html
hd Html -> HtmlTable -> HtmlTable
forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
</> (Html
bar Html -> HtmlTable -> HtmlTable
forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
`beside` [[[Char]]] -> [HtmlTree] -> HtmlTable
treeHtmls [[[Char]]]
morecolors [HtmlTree]
ts)
                 HtmlTable -> Html -> HtmlTable
forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
</> Html
tl
        where
              -- This stops a column of colors being the same
              -- color as the immeduately outside nesting bar.
              morecolors :: [[[Char]]]
morecolors = ([[Char]] -> Bool) -> [[[Char]]] -> [[[Char]]]
forall a. (a -> Bool) -> [a] -> [a]
filter (([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
c)([Char] -> Bool) -> ([[Char]] -> [Char]) -> [[Char]] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
head) ([[Char]] -> [[[Char]]]
forall {a}. [a] -> [[a]]
manycolors [[Char]]
cs)
              bar :: Html
bar = Html -> Html
td (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [[Char] -> HtmlAttr
bgcolor [Char]
c,[Char] -> HtmlAttr
width [Char]
"10"] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
spaceHtml
              hd :: Html
hd = Html -> Html
td (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [[Char] -> HtmlAttr
bgcolor [Char]
c] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
hopen
              tl :: Html
tl = Html -> Html
td (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [[Char] -> HtmlAttr
bgcolor [Char]
c] (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
hclose
      treeHtml' [[Char]]
_ HtmlTree
_ = [Char] -> HtmlTable
forall a. HasCallStack => [Char] -> a
error [Char]
"The imposible happens"

instance HTML HtmlTree where
      toHtml :: HtmlTree -> Html
toHtml HtmlTree
x = [[Char]] -> HtmlTree -> Html
treeHtml [[Char]]
treeColors HtmlTree
x

-- type "length treeColors" to see how many colors are here.
treeColors :: [[Char]]
treeColors = [[Char]
"#88ccff",[Char]
"#ffffaa",[Char]
"#ffaaff",[Char]
"#ccffff"] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
treeColors


-- ---------------------------------------------------------------------------
-- Html Debugging Combinators
 
-- This uses the above tree rendering function, and displays the
-- Html as a tree structure, allowing debugging of what is
-- actually getting produced.

debugHtml :: (HTML a) => a -> Html
debugHtml :: forall a. HTML a => a -> Html
debugHtml a
obj = Html -> Html
table (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [Int -> HtmlAttr
border Int
0] (Html -> Html) -> HtmlTable -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< 
                  ( Html -> Html
th (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [[Char] -> HtmlAttr
bgcolor [Char]
"#008888"] 
                     (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html -> Html
underline
                       (Html -> Html) -> [Char] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [Char]
"Debugging Output"
               Html -> Html -> HtmlTable
forall ht1 ht2.
(HTMLTABLE ht1, HTMLTABLE ht2) =>
ht1 -> ht2 -> HtmlTable
</>  Html -> Html
td (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< ([HtmlTree] -> Html
forall a. HTML a => a -> Html
toHtml (Html -> [HtmlTree]
debug' (a -> Html
forall a. HTML a => a -> Html
toHtml a
obj)))
              )
  where

      debug' :: Html -> [HtmlTree]
      debug' :: Html -> [HtmlTree]
debug' (Html [HtmlElement]
markups) = (HtmlElement -> HtmlTree) -> [HtmlElement] -> [HtmlTree]
forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> HtmlTree
debug [HtmlElement]
markups

      debug :: HtmlElement -> HtmlTree
      debug :: HtmlElement -> HtmlTree
debug (HtmlString [Char]
str) = Html -> HtmlTree
HtmlLeaf (Html
spaceHtml Html -> Html -> Html
forall a b. (HTML a, HTML b) => a -> b -> Html
+++
                                              [[Char]] -> Html
linesToHtml ([Char] -> [[Char]]
lines [Char]
str))
      debug (HtmlTag {
              markupTag :: HtmlElement -> [Char]
markupTag = [Char]
markupTag,
              markupContent :: HtmlElement -> Html
markupContent = Html
markupContent,
              markupAttrs :: HtmlElement -> [HtmlAttr]
markupAttrs  = [HtmlAttr]
markupAttrs
              }) =
              case Html
markupContent of
                Html [] -> Html -> [HtmlTree] -> Html -> HtmlTree
HtmlNode Html
hd [] Html
noHtml
                Html [HtmlElement]
xs -> Html -> [HtmlTree] -> Html -> HtmlTree
HtmlNode Html
hd ((HtmlElement -> HtmlTree) -> [HtmlElement] -> [HtmlTree]
forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> HtmlTree
debug [HtmlElement]
xs) Html
tl
        where
              args :: [Char]
args = if [HtmlAttr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HtmlAttr]
markupAttrs
                     then [Char]
""
                     else [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ((HtmlAttr -> [Char]) -> [HtmlAttr] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map HtmlAttr -> [Char]
forall a. Show a => a -> [Char]
show [HtmlAttr]
markupAttrs) 
              hd :: Html
hd = Html -> Html
font (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [[Char] -> HtmlAttr
size [Char]
"1"] (Html -> Html) -> [Char] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< ([Char]
"<" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
markupTag [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
args [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
">")
              tl :: Html
tl = Html -> Html
font (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [[Char] -> HtmlAttr
size [Char]
"1"] (Html -> Html) -> [Char] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< ([Char]
"</" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
markupTag [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
">")

-- ---------------------------------------------------------------------------
-- Hotlink datatype

data HotLink = HotLink {
      HotLink -> [Char]
hotLinkURL        :: URL,
      HotLink -> [Html]
hotLinkContents   :: [Html],
      HotLink -> [HtmlAttr]
hotLinkAttributes :: [HtmlAttr]
      } deriving Int -> HotLink -> [Char] -> [Char]
[HotLink] -> [Char] -> [Char]
HotLink -> [Char]
(Int -> HotLink -> [Char] -> [Char])
-> (HotLink -> [Char])
-> ([HotLink] -> [Char] -> [Char])
-> Show HotLink
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> HotLink -> [Char] -> [Char]
showsPrec :: Int -> HotLink -> [Char] -> [Char]
$cshow :: HotLink -> [Char]
show :: HotLink -> [Char]
$cshowList :: [HotLink] -> [Char] -> [Char]
showList :: [HotLink] -> [Char] -> [Char]
Show

instance HTML HotLink where
      toHtml :: HotLink -> Html
toHtml HotLink
hl = Html -> Html
anchor (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! ([Char] -> HtmlAttr
href (HotLink -> [Char]
hotLinkURL HotLink
hl) HtmlAttr -> [HtmlAttr] -> [HtmlAttr]
forall a. a -> [a] -> [a]
: HotLink -> [HtmlAttr]
hotLinkAttributes HotLink
hl)
                      (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< HotLink -> [Html]
hotLinkContents HotLink
hl

hotlink :: URL -> [Html] -> HotLink
hotlink :: [Char] -> [Html] -> HotLink
hotlink [Char]
url [Html]
h = HotLink {
      hotLinkURL :: [Char]
hotLinkURL = [Char]
url,
      hotLinkContents :: [Html]
hotLinkContents = [Html]
h,
      hotLinkAttributes :: [HtmlAttr]
hotLinkAttributes = [] }


-- ---------------------------------------------------------------------------
-- More Combinators

-- (Abridged from Erik Meijer's Original Html library)

ordList   :: (HTML a) => [a] -> Html
ordList :: forall a. HTML a => [a] -> Html
ordList [a]
items = Html -> Html
olist (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (a -> Html) -> [a] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map (Html -> Html
li (Html -> Html) -> a -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<) [a]
items

unordList :: (HTML a) => [a] -> Html
unordList :: forall a. HTML a => [a] -> Html
unordList [a]
items = Html -> Html
ulist (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< (a -> Html) -> [a] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map (Html -> Html
li (Html -> Html) -> a -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<<) [a]
items

defList   :: (HTML a,HTML b) => [(a,b)] -> Html
defList :: forall a b. (HTML a, HTML b) => [(a, b)] -> Html
defList [(a, b)]
items
 = Html -> Html
dlist (Html -> Html) -> [[Html]] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [ [ Html -> Html
dterm (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html -> Html
bold (Html -> Html) -> a -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< a
dt, Html -> Html
ddef (Html -> Html) -> b -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< b
dd ] | (a
dt,b
dd) <- [(a, b)]
items ]


widget :: String -> String -> [HtmlAttr] -> Html
widget :: [Char] -> [Char] -> [HtmlAttr] -> Html
widget [Char]
w [Char]
n [HtmlAttr]
markupAttrs = Html
input Html -> [HtmlAttr] -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! ([[Char] -> HtmlAttr
thetype [Char]
w,[Char] -> HtmlAttr
name [Char]
n] [HtmlAttr] -> [HtmlAttr] -> [HtmlAttr]
forall a. [a] -> [a] -> [a]
++ [HtmlAttr]
markupAttrs)

checkbox :: String -> String -> Html
hidden   :: String -> String -> Html
radio    :: String -> String -> Html
reset    :: String -> String -> Html
submit   :: String -> String -> Html
password :: String           -> Html
textfield :: String          -> Html
afile    :: String           -> Html
clickmap :: String           -> Html

checkbox :: [Char] -> [Char] -> Html
checkbox [Char]
n [Char]
v = [Char] -> [Char] -> [HtmlAttr] -> Html
widget [Char]
"CHECKBOX" [Char]
n [[Char] -> HtmlAttr
value [Char]
v]
hidden :: [Char] -> [Char] -> Html
hidden   [Char]
n [Char]
v = [Char] -> [Char] -> [HtmlAttr] -> Html
widget [Char]
"HIDDEN"   [Char]
n [[Char] -> HtmlAttr
value [Char]
v]
radio :: [Char] -> [Char] -> Html
radio    [Char]
n [Char]
v = [Char] -> [Char] -> [HtmlAttr] -> Html
widget [Char]
"RADIO"    [Char]
n [[Char] -> HtmlAttr
value [Char]
v]
reset :: [Char] -> [Char] -> Html
reset    [Char]
n [Char]
v = [Char] -> [Char] -> [HtmlAttr] -> Html
widget [Char]
"RESET"    [Char]
n [[Char] -> HtmlAttr
value [Char]
v]
submit :: [Char] -> [Char] -> Html
submit   [Char]
n [Char]
v = [Char] -> [Char] -> [HtmlAttr] -> Html
widget [Char]
"SUBMIT"   [Char]
n [[Char] -> HtmlAttr
value [Char]
v]
password :: [Char] -> Html
password [Char]
n   = [Char] -> [Char] -> [HtmlAttr] -> Html
widget [Char]
"PASSWORD" [Char]
n []
textfield :: [Char] -> Html
textfield [Char]
n  = [Char] -> [Char] -> [HtmlAttr] -> Html
widget [Char]
"TEXT"     [Char]
n []
afile :: [Char] -> Html
afile    [Char]
n   = [Char] -> [Char] -> [HtmlAttr] -> Html
widget [Char]
"FILE"     [Char]
n []
clickmap :: [Char] -> Html
clickmap [Char]
n   = [Char] -> [Char] -> [HtmlAttr] -> Html
widget [Char]
"IMAGE"    [Char]
n []

menu :: String -> [Html] -> Html
menu :: [Char] -> [Html] -> Html
menu [Char]
n [Html]
choices
   = Html -> Html
select (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [[Char] -> HtmlAttr
name [Char]
n] (Html -> Html) -> [Html] -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< [ Html -> Html
option (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html -> Html
p (Html -> Html) -> Html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< Html
choice | Html
choice <- [Html]
choices ]

gui :: String -> Html -> Html
gui :: [Char] -> Html -> Html
gui [Char]
act = Html -> Html
form (Html -> Html) -> [HtmlAttr] -> Html -> Html
forall a. ADDATTRS a => a -> [HtmlAttr] -> a
! [[Char] -> HtmlAttr
action [Char]
act,[Char] -> HtmlAttr
method [Char]
"POST"]

-- ---------------------------------------------------------------------------
-- Html Rendering
 
-- Uses the append trick to optimize appending.
-- The output is quite messy, because space matters in
-- HTML, so we must not generate needless spaces.

renderHtml :: (HTML html) => html -> String
renderHtml :: forall html. HTML html => html -> [Char]
renderHtml html
theHtml =
      [Char]
renderMessage [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ 
         (([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char])
-> ([Char] -> [Char]) -> [[Char] -> [Char]] -> [Char] -> [Char]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) [Char] -> [Char]
forall a. a -> a
id ((HtmlElement -> [Char] -> [Char])
-> [HtmlElement] -> [[Char] -> [Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> HtmlElement -> [Char] -> [Char]
renderHtml' Int
0)
                           (Html -> [HtmlElement]
getHtmlElements ([Char] -> Html -> Html
tag [Char]
"HTML" (Html -> Html) -> html -> Html
forall a b. HTML a => (Html -> b) -> a -> b
<< html
theHtml))) [Char]
"\n"

renderMessage :: [Char]
renderMessage =
      [Char]
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 FINAL//EN\">\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
      [Char]
"<!--Rendered using the Haskell Html Library v0.2-->\n"

-- Warning: spaces matters in HTML. You are better using renderHtml.
-- This is intentually very inefficent to "encorage" this,
-- but the neater version in easier when debugging.

-- Local Utilities
prettyHtml :: (HTML html) => html -> String
prettyHtml :: forall html. HTML html => html -> [Char]
prettyHtml html
theHtml = 
        [[Char]] -> [Char]
unlines
      ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      ([[[Char]]] -> [[Char]]) -> [[[Char]]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (HtmlElement -> [[Char]]) -> [HtmlElement] -> [[[Char]]]
forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> [[Char]]
prettyHtml'
      ([HtmlElement] -> [[[Char]]]) -> [HtmlElement] -> [[[Char]]]
forall a b. (a -> b) -> a -> b
$ Html -> [HtmlElement]
getHtmlElements
      (Html -> [HtmlElement]) -> Html -> [HtmlElement]
forall a b. (a -> b) -> a -> b
$ html -> Html
forall a. HTML a => a -> Html
toHtml html
theHtml

renderHtml' :: Int -> HtmlElement -> ShowS
renderHtml' :: Int -> HtmlElement -> [Char] -> [Char]
renderHtml' Int
_ (HtmlString [Char]
str) = [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
(++) [Char]
str
renderHtml' Int
n (HtmlTag
              { markupTag :: HtmlElement -> [Char]
markupTag = [Char]
name,
                markupContent :: HtmlElement -> Html
markupContent = Html
html,
                markupAttrs :: HtmlElement -> [HtmlAttr]
markupAttrs = [HtmlAttr]
markupAttrs })
      = if Html -> Bool
isNoHtml Html
html Bool -> Bool -> Bool
&& [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char]
name [[Char]]
validHtmlITags
        then Bool -> [Char] -> [HtmlAttr] -> Int -> [Char] -> [Char]
renderTag Bool
True [Char]
name [HtmlAttr]
markupAttrs Int
n
        else (Bool -> [Char] -> [HtmlAttr] -> Int -> [Char] -> [Char]
renderTag Bool
True [Char]
name [HtmlAttr]
markupAttrs Int
n
             ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char])
-> ([Char] -> [Char]) -> [[Char] -> [Char]] -> [Char] -> [Char]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) [Char] -> [Char]
forall a. a -> a
id ((HtmlElement -> [Char] -> [Char])
-> [HtmlElement] -> [[Char] -> [Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> HtmlElement -> [Char] -> [Char]
renderHtml' (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)) (Html -> [HtmlElement]
getHtmlElements Html
html))
             ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> [Char] -> [HtmlAttr] -> Int -> [Char] -> [Char]
renderTag Bool
False [Char]
name [] Int
n)

prettyHtml' :: HtmlElement -> [String]
prettyHtml' :: HtmlElement -> [[Char]]
prettyHtml' (HtmlString [Char]
str) = [[Char]
str]
prettyHtml' (HtmlTag
              { markupTag :: HtmlElement -> [Char]
markupTag = [Char]
name,
                markupContent :: HtmlElement -> Html
markupContent = Html
html,
                markupAttrs :: HtmlElement -> [HtmlAttr]
markupAttrs = [HtmlAttr]
markupAttrs })
      = if Html -> Bool
isNoHtml Html
html Bool -> Bool -> Bool
&& [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char]
name [[Char]]
validHtmlITags
        then 
         [[Char] -> [Char]
rmNL (Bool -> [Char] -> [HtmlAttr] -> Int -> [Char] -> [Char]
renderTag Bool
True [Char]
name [HtmlAttr]
markupAttrs Int
0 [Char]
"")]
        else
         [[Char] -> [Char]
rmNL (Bool -> [Char] -> [HtmlAttr] -> Int -> [Char] -> [Char]
renderTag Bool
True [Char]
name [HtmlAttr]
markupAttrs Int
0 [Char]
"")] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ 
          [[Char]] -> [[Char]]
shift ([[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((HtmlElement -> [[Char]]) -> [HtmlElement] -> [[[Char]]]
forall a b. (a -> b) -> [a] -> [b]
map HtmlElement -> [[Char]]
prettyHtml' (Html -> [HtmlElement]
getHtmlElements Html
html))) [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++
         [[Char] -> [Char]
rmNL (Bool -> [Char] -> [HtmlAttr] -> Int -> [Char] -> [Char]
renderTag Bool
False [Char]
name [] Int
0 [Char]
"")]
  where
      shift :: [[Char]] -> [[Char]]
shift = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\[Char]
x -> [Char]
"   " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x)
rmNL :: [Char] -> [Char]
rmNL = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')

-- This prints the Tags The lack of spaces in intentunal, because Html is
-- actually space dependant.

renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS
renderTag :: Bool -> [Char] -> [HtmlAttr] -> Int -> [Char] -> [Char]
renderTag Bool
x [Char]
name [HtmlAttr]
markupAttrs Int
n [Char]
r
      = [Char]
open [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [HtmlAttr] -> [Char]
rest [HtmlAttr]
markupAttrs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
">" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
r
  where
      open :: [Char]
open = if Bool
x then [Char]
"<" else [Char]
"</"
      
      nl :: [Char]
nl = [Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8) Char
'\t' 
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8) Char
' '

      rest :: [HtmlAttr] -> [Char]
rest []   = [Char]
nl
      rest [HtmlAttr]
attr = [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ((HtmlAttr -> [Char]) -> [HtmlAttr] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map HtmlAttr -> [Char]
showPair [HtmlAttr]
attr) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nl

      showPair :: HtmlAttr -> String
      showPair :: HtmlAttr -> [Char]
showPair (HtmlAttr [Char]
tag [Char]
val)
              = [Char]
tag [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = \"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
val  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\""