|
module Html ( module Html, ) where import qualified HtmlBlockTable 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 |
data Html {- - ..just..plain..normal..text... but using © and &amb;, etc. -} = HtmlString String {- - <thetag {..attrs..}> ..inside.. </thetag> -} | HtmlTag { -- tag with an internal html thetag :: String, attrs :: [HtmlAttr], innerHtml :: [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 |
class MARKUP a where markup :: a -> [Html] markupList :: [a] -> [Html] markup _ = [] markupList xs = concat (map markup xs) instance MARKUP Html where markup a = [a] instance MARKUP Char where markup a = markup [a] markupList [] = [] markupList str = [HtmlString (stringToHtmlString str)] instance (MARKUP a) => MARKUP [a] where markup xs = markupList xs class ADDATTRS a where (!) :: a -> [HtmlAttr] -> a instance (ADDATTRS b) => ADDATTRS (a -> b) where fn ! attr = \ arg -> fn arg ! attr instance ADDATTRS Html where html@(HtmlTag {}) ! newAttrs = html { attrs = attrs html ++ newAttrs } html ! _ = html |
(<<) :: (MARKUP a) => ([Html] -> b) -> a -> b fn << arg = fn (markup arg) a +++ b = concat [markup a,markup b] noHtmls :: [Html] noHtmls = [] tag :: String -> [Html] -> Html tag str htmls = HtmlTag { thetag = str, attrs = [], innerHtml = htmls } itag :: String -> Html itag str = tag str [] emptyAttr :: String -> HtmlAttr emptyAttr s = HtmlAttr s "" intAttr :: String -> Int -> HtmlAttr intAttr s i = HtmlAttr s (show i) strAttr :: String -> String -> HtmlAttr strAttr s t = HtmlAttr s 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 = concatMap fixChar where fixChar '<' = "<" fixChar '>' = ">" fixChar '&' = "&" fixChar '"' = """ fixChar c = [c] |
instance Show Html where showsPrec _ html = showString (prettyHtml html) showList htmls = showString (concat (map show htmls)) instance Show HtmlAttr where showsPrec _ (HtmlAttr str val) = showString str . showString "=" . shows val |
type URL = String |
primHtml :: String -> Html primHtml = HtmlString |
stringToHtml :: String -> Html stringToHtml = primHtml . stringToHtmlString |
lineToHtml :: String -> Html lineToHtml = primHtml . concatMap htmlizeChar2 . stringToHtmlString where htmlizeChar2 ' ' = " " htmlizeChar2 c = [c] |
-- (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 thetitle :: [Html] -> Html tr :: [Html] -> Html tt :: [Html] -> Html ulist :: [Html] -> Html underline :: [Html] -> Html variable :: [Html] -> Html address = tag "ADDRESS" anchor = tag "A" applet = tag "APPLET" area = itag "AREA" basefont = itag "BASEFONT" big = tag "BIG" blockquote = tag "BLOCKQUOTE" body = tag "BODY" bold = tag "B" br = itag "BR" caption = tag "CAPTION" center = tag "CENTER" cite = tag "CITE" ddef = tag "DD" define = tag "DFN" dlist = tag "DL" dterm = tag "DT" emphasize = tag "EM" fieldset = tag "FIELDSET" font = tag "FONT" form = tag "FORM" frame = tag "FRAME" frameset = tag "FRAMESET" h1 = tag "H1" h2 = tag "H2" h3 = tag "H3" h4 = tag "H4" h5 = tag "H5" h6 = tag "H6" header = tag "HEAD" hr = itag "HR" image = itag "IMG" input = itag "INPUT" italics = tag "I" keyboard = tag "KBD" legend = tag "LEGEND" li = tag "LI" meta = itag "META" noframes = tag "NOFRAMES" olist = tag "OL" option = tag "OPTION" paragraph = tag "P" param = itag "PARAM" pre = tag "PRE" sample = tag "SAMP" select = tag "SELECT" small = tag "SMALL" strong = tag "STRONG" style = tag "STYLE" sub = tag "SUB" sup = tag "SUP" table = tag "TABLE" td = tag "TD" textarea = tag "TEXTAREA" th = tag "TH" thebase = itag "BASE" thecode = tag "CODE" thediv = tag "DIV" thehtml = tag "HTML" thelink = tag "LINK" themap = tag "MAP" thetitle = tag "TITLE" tr = tag "TR" tt = tag "TT" ulist = tag "UL" underline = tag "U" variable = tag "VAR" |
-- (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 identity :: 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 = strAttr "ACTION" align = strAttr "ALIGN" alink = strAttr "ALINK" alt = strAttr "ALT" altcode = strAttr "ALTCODE" archive = strAttr "ARCHIVE" background = strAttr "BACKGROUND" base = strAttr "BASE" bgcolor = strAttr "BGCOLOR" border = intAttr "BORDER" bordercolor = strAttr "BORDERCOLOR" cellpadding = intAttr "CELLPADDING" cellspacing = intAttr "CELLSPACING" checked = emptyAttr "CHECKED" clear = strAttr "CLEAR" code = strAttr "CODE" codebase = strAttr "CODEBASE" color = strAttr "COLOR" cols = strAttr "COLS" colspan = intAttr "COLSPAN" compact = emptyAttr "COMPACT" content = strAttr "CONTENT" coords = strAttr "COORDS" enctype = strAttr "ENCTYPE" face = strAttr "FACE" frameborder = intAttr "FRAMEBORDER" height = intAttr "HEIGHT" href = strAttr "HREF" hspace = intAttr "HSPACE" httpequiv = strAttr "HTTPEQUIV" identity = strAttr "ID" ismap = emptyAttr "ISMAP" lang = strAttr "LANG" link = strAttr "LINK" marginheight = intAttr "MARGINHEIGHT" marginwidth = intAttr "MARGINWIDTH" maxlength = intAttr "MAXLENGTH" method = strAttr "METHOD" multiple = emptyAttr "MULTIPLE" name = strAttr "NAME" nohref = emptyAttr "NOHREF" noresize = emptyAttr "NORESIZE" noshade = emptyAttr "NOSHADE" nowrap = emptyAttr "NOWRAP" rel = strAttr "REL" rev = strAttr "REV" rows = strAttr "ROWS" rowspan = intAttr "ROWSPAN" rules = strAttr "RULES" scrolling = strAttr "SCROLLING" selected = emptyAttr "SELECTED" shape = strAttr "SHAPE" size = strAttr "SIZE" src = strAttr "SRC" start = intAttr "START" target = strAttr "TARGET" text = strAttr "TEXT" theclass = strAttr "CLASS" thestyle = strAttr "STYLE" thetype = strAttr "TYPE" title = strAttr "TITLE" usemap = strAttr "USEMAP" valign = strAttr "VALIGN" value = strAttr "VALUE" version = strAttr "VERSION" vlink = strAttr "VLINK" vspace = intAttr "VSPACE" width = strAttr "WIDTH" -- (automatically generated) validHtmlTags :: [String] validHtmlTags = [ "ADDRESS", "A", "APPLET", "BIG", "BLOCKQUOTE", "BODY", "B", "CAPTION", "CENTER", "CITE", "DD", "DFN", "DL", "DT", "EM", "FIELDSET", "FONT", "FORM", "FRAME", "FRAMESET", "H1", "H2", "H3", "H4", "H5", "H6", "HEAD", "I", "KBD", "LEGEND", "LI", "NOFRAMES", "OL", "OPTION", "P", "PRE", "SAMP", "SELECT", "SMALL", "STRONG", "STYLE", "SUB", "SUP", "TABLE", "TD", "TEXTAREA", "TH", "CODE", "DIV", "HTML", "LINK", "MAP", "TITLE", "TR", "TT", "UL", "U", "VAR"] validHtmlITags :: [String] validHtmlITags = [ "AREA", "BASEFONT", "BR", "HR", "IMG", "INPUT", "META", "PARAM", "BASE"] validHtmlAttrs :: [String] validHtmlAttrs = [ "ACTION", "ALIGN", "ALINK", "ALT", "ALTCODE", "ARCHIVE", "BACKGROUND", "BASE", "BGCOLOR", "BORDER", "BORDERCOLOR", "CELLPADDING", "CELLSPACING", "CHECKED", "CLEAR", "CODE", "CODEBASE", "COLOR", "COLS", "COLSPAN", "COMPACT", "CONTENT", "COORDS", "ENCTYPE", "FACE", "FRAMEBORDER", "HEIGHT", "HREF", "HSPACE", "HTTPEQUIV", "ID", "ISMAP", "LANG", "LINK", "MARGINHEIGHT", "MARGINWIDTH", "MAXLENGTH", "METHOD", "MULTIPLE", "NAME", "NOHREF", "NORESIZE", "NOSHADE", "NOWRAP", "REL", "REV", "ROWS", "ROWSPAN", "RULES", "SCROLLING", "SELECTED", "SHAPE", "SIZE", "SRC", "START", "TARGET", "TEXT", "CLASS", "STYLE", "TYPE", "TITLE", "USEMAP", "VALIGN", "VALUE", "VERSION", "VLINK", "VSPACE", "WIDTH"] |
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 = "aqua" black = "black" blue = "blue" fuchsia = "fuchsia" gray = "gray" green = "green" lime = "lime" maroon = "maroon" navy = "navy" olive = "olive" purple = "purple" red = "red" silver = "silver" teal = "teal" yellow = "yellow" white = "white" |
linesToHtml :: [String] -> [Html] linesToHtml [] = [] linesToHtml (x:[]) = [lineToHtml x] linesToHtml (x:xs) = lineToHtml x +++ br +++ linesToHtml xs |
primHtmlChar :: String -> Html copyright :: Html spaceHtml :: Html bullet :: Html p :: [Html] -> Html primHtmlChar = \ x -> primHtml ("&" ++ x ++ ";") copyright = primHtmlChar "copy" spaceHtml = primHtmlChar "nbsp" bullet = primHtmlChar "#149" p = paragraph |
class HTMLTABLE ht where cell :: ht -> HtmlTable instance HTMLTABLE HtmlTable where cell = id instance HTMLTABLE Html where cell h = let cellFn x y = h ! (add x colspan $ add y rowspan $ []) add 1 fn rest = rest add n fn rest = fn n : rest r = BT.single cellFn in mkHtmlTable r |
Int -> Int -> HtmlWhen 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 r = HtmlTable r |
above a b = combine BT.above (cell a) (cell b) (</>) = above beside a b = combine BT.beside (cell a) (cell b) (<->) = beside |
combine fn (HtmlTable a) (HtmlTable b) = mkHtmlTable (a `fn` b) |
aboves [] = error "aboves []" aboves xs = foldr1 (</>) (map cell xs) besides [] = error "besides []" besides xs = foldr1 (<->) (map cell xs) |
renderTable :: BT.BlockTable (Int -> Int -> Html) -> [Html] renderTable theTable = [tr [theCell x y | (theCell,(x,y)) <- theRow ] | theRow <- BT.getMatrix theTable] instance MARKUP HtmlTable where markup (HtmlTable tab) = renderTable tab instance Show HtmlTable where showsPrec _ (HtmlTable tab) = shows (renderTable tab) |
simpleTable attr cellAttr lst = table ! attr << (aboves . map (besides . map ((td ! cellAttr) . markup)) ) lst |
data HtmlTree = HtmlLeaf [Html] | HtmlNode [Html] [HtmlTree] [Html] treeHtml :: [String] -> HtmlTree -> Html treeHtml colors h = table ! [ border 0, cellpadding 0, cellspacing 2] << treeHtml' colors h where manycolors = scanr (:) [] treeHtmls :: [[String]] -> [HtmlTree] -> HtmlTable treeHtmls c ts = aboves (zipWith treeHtml' c ts) treeHtml' :: [String] -> HtmlTree -> HtmlTable treeHtml' (c:_) (HtmlLeaf leaf) = cell (td ! [width "100%"] << bold << leaf) treeHtml' (c:cs@(c2:_)) (HtmlNode hopen ts hclose) = if null ts && null hclose then cell hd else if null ts then hd </> bar `beside` (td ! [bgcolor c2] << spaceHtml) </> tl else hd </> (bar `beside` treeHtmls morecolors ts) </> tl where -- This stops a column of colors being the same -- color as the immeduately outside nesting bar. morecolors = filter ((/= c).head) (manycolors cs) bar = td ! [bgcolor c,width "10"] << spaceHtml hd = td ! [bgcolor c] << hopen tl = td ! [bgcolor c] << hclose treeHtml' _ _ = error "The imposible happens" instance MARKUP HtmlTree where markup x = [treeHtml treeColors x] -- type "length treeColors" to see how many colors are here. treeColors = ["#88ccff","#ffffaa","#ffaaff","#ccffff"] ++ treeColors |
debugHtml :: (MARKUP a) => a -> Html debugHtml obj = table ! [border 0] << ( th ! [bgcolor "#008888"] << underline << "Debugging Output" </> td << (map (markup . debug) hobj) ) where hobj = markup obj debug :: Html -> HtmlTree debug (HtmlString str) = HtmlLeaf (spaceHtml : markup str) debug (HtmlTag { thetag = thetag, innerHtml = innerHtml, attrs = attrs }) = case innerHtml of [] -> HtmlNode [hd] [] [] xs -> HtmlNode [hd] (map debug xs) [tl] where args = unwords (map show attrs) hd = font ! [size "1"] << ("<" ++ thetag ++ " " ++ args ++ ">") tl = font ! [size "1"] << ("</" ++ thetag ++ ">") |
data HotLink = HotLink { hotLinkURL :: URL, hotLinkContents :: [Html], hotLinkAttributes :: [HtmlAttr] } deriving Show instance MARKUP HotLink where markup hl = [anchor ! (href (hotLinkURL hl) : hotLinkAttributes hl) << hotLinkContents hl] hotlink :: URL -> [Html] -> HotLink hotlink url h = HotLink { hotLinkURL = url, hotLinkContents = h, hotLinkAttributes = [] } |
-- (Abridged from Erik Meijer's Original Html library) ordList :: (MARKUP a) => [a] -> Html ordList items = olist << map (li <<) items unordList :: (MARKUP a) => [a] -> Html unordList items = ulist << map (li <<) items defList :: (MARKUP a,MARKUP b) => [(a,b)] -> Html defList items = dlist << [ [ dterm << bold << dt, ddef << dd ] | (dt,dd) <- items ] widget :: String -> String -> [HtmlAttr] -> Html widget w n attrs = input ! ([thetype w,name n] ++ attrs) 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 n v = widget "CHECKBOX" n [value v] hidden n v = widget "HIDDEN" n [value v] radio n v = widget "RADIO" n [value v] reset n v = widget "RESET" n [value v] submit n v = widget "SUBMIT" n [value v] password n = widget "PASSWORD" n [] textfield n = widget "TEXT" n [] afile n = widget "FILE" n [] clickmap n = widget "IMAGE" n [] menu :: String -> [Html] -> Html menu n choices = select ! [name n] << [ option << p << choice | choice <- choices ] gui :: String -> [Html] -> Html gui act = form ! [action act,method "POST"] |
renderHtml :: (MARKUP html) => html -> String renderHtml theHtml = renderMessage ++ renderHtml' 0 (tag "HTML" << theHtml) "\n" renderMessage = "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 FINAL//EN\">\n" ++ "<!--Rendered using the Haskell Html Library v0.1-->\n" |
-- Local Utilities prettyHtml :: (MARKUP html) => html -> String prettyHtml theHtml = unlines $ concat $ map prettyHtml' $ markup theHtml renderHtml' :: Int -> Html -> ShowS renderHtml' _ (HtmlString str) = (++) str renderHtml' n (HtmlTag { thetag = name, innerHtml = html, attrs = attrs }) = if null html && elem name validHtmlITags then renderTag True name attrs n else (renderTag True name attrs n . foldr (.) id (map (renderHtml' (n+2)) html) . renderTag False name [] n) prettyHtml' :: Html -> [String] prettyHtml' (HtmlString str) = [str] prettyHtml' (HtmlTag { thetag = name, innerHtml = html, attrs = attrs }) = if null html && elem name validHtmlITags then [rmNL (renderTag True name attrs 0 "")] else [rmNL (renderTag True name attrs 0 "")] ++ shift (concat (map prettyHtml' html)) ++ [rmNL (renderTag False name [] 0 "")] shift = map (\x -> " " ++ x) rmNL = filter (/= '\n') |
renderTag :: Bool -> String -> [HtmlAttr] -> Int -> ShowS renderTag x name attrs n r = open ++ name ++ rest attrs ++ ">" ++ r where open = if x then "<" else "</" nl = "\n" ++ replicate (n `div` 8) '\t' ++ replicate (n `mod` 8) ' ' rest [] = nl rest attr = " " ++ unwords (map showPair attr) ++ nl showPair :: HtmlAttr -> String showPair (HtmlAttr tag val) = tag ++ " = \"" ++ val ++ "\"" -- End of Local Utilities |