--- /dev/null
+-------------------------------------------------------------------------------\r
+-- $Id: DataHtml.hs,v 1.1 1999/11/12 11:54:17 simonmar Exp $\r
+--\r
+-- Copyright (c) 1999 Andy Gill\r
+-------------------------------------------------------------------------------\r
+\r
+module DataHtml (\r
+ Html, HtmlName, HtmlAttr, HtmlTable,\r
+ (+++), verbatim, {- tag, atag, -} noHtml, primHtml, \r
+ concatHtml, htmlStr, htmlLine,\r
+ h1,h2,h3,h4,h5,h6, \r
+ font, bold, anchor, header, body, theTitle, paragraph, italics,\r
+ ul, tt,\r
+ bar, meta, li,\r
+ {- tr, int, percent -}\r
+ color, bgcolor, href, name, title, height, width, align, valign,\r
+ border, size, cellpadding, cellspacing,\r
+ p, hr, copyright, spaceHtml, \r
+ renderHtml, \r
+ cellHtml, (+/+), above, (+-+), beside, aboves, besides, \r
+ renderTable, simpleTable, \r
+ ) where\r
+\r
+import qualified OptTable as OT\r
+\r
+infixr 5 +++ -- appending Html\r
+infixr 3 +/+ -- combining HtmlTable\r
+infixr 4 +-+ -- combining HtmlTable\r
+\r
+data Html\r
+ = HtmlAppend Html Html -- Some Html, followed by more text\r
+ | HtmlVerbatim Html -- Turn on or off smart formating\r
+ | HtmlEmpty -- Nothing!\r
+ | HtmlNestingTag HtmlName [HtmlAttr] Html\r
+ | HtmlSimpleTag HtmlName [HtmlAttr]\r
+ | HtmlString String\r
+ deriving (Show)\r
+\r
+{-\r
+ - A important property of Html is all strings inside the\r
+ - structure are already in Html friendly format.\r
+ - For example, use of >,etc.\r
+ -}\r
+\r
+type HtmlName = String\r
+type HtmlAttr = (HtmlName,Either Int String)\r
+type HtmlTable = OT.OptTable (Int -> Int -> Html)\r
+\r
+------------------------------------------------------------------------------\r
+-- Interface\r
+------------------------------------------------------------------------------\r
+\r
+-- primitive combinators\r
+(+++) :: Html -> Html -> Html\r
+verbatim :: Html -> Html\r
+tag :: String -> [HtmlAttr] -> Html -> Html\r
+atag :: String -> [HtmlAttr] -> Html\r
+noHtml :: Html\r
+primHtml :: String -> Html\r
+\r
+-- useful combinators\r
+concatHtml :: [Html] -> Html\r
+htmlStr, htmlLine :: String -> Html\r
+\r
+-- html constructors\r
+h1,h2,h3,h4,h5,h6 :: [HtmlAttr] -> Html -> Html\r
+font, bold, anchor, \r
+ header, body, \r
+ theTitle, paragraph,\r
+ italics, ul, tt :: [HtmlAttr] -> Html -> Html\r
+bar, meta, li :: [HtmlAttr] -> Html\r
+\r
+-- html attributes\r
+str :: String -> String -> HtmlAttr\r
+int :: String -> Int -> HtmlAttr\r
+percent :: String -> Int -> HtmlAttr\r
+\r
+color, bgcolor, href,\r
+ name, title, height,\r
+ width, align, valign :: String -> HtmlAttr\r
+\r
+border, size,\r
+ cellpadding,\r
+ cellspacing :: Int -> HtmlAttr \r
+\r
+-- abbriviations\r
+\r
+p :: Html -> Html\r
+hr :: Html\r
+copyright :: Html\r
+spaceHtml :: Html\r
+\r
+-- rendering\r
+renderHtml :: Html -> String\r
+\r
+-- html tables\r
+cellHtml :: [HtmlAttr] -> Html -> HtmlTable\r
+(+/+),above,\r
+ (+-+),beside :: HtmlTable -> HtmlTable -> HtmlTable\r
+aboves, besides :: [HtmlTable] -> HtmlTable\r
+renderTable :: [HtmlAttr] -> HtmlTable -> Html\r
+simpleTable :: [HtmlAttr] -> [HtmlAttr] -> [[Html]] \r
+ -> Html\r
+\r
+------------------------------------------------------------------------------\r
+-- Basic, primitive combinators\r
+\r
+-- This is intentionally lazy in the second argument.\r
+(HtmlAppend x y) +++ z = x +++ (y +++ z)\r
+(HtmlEmpty) +++ z = z\r
+x +++ z = HtmlAppend x z\r
+\r
+verbatim = HtmlVerbatim\r
+tag = HtmlNestingTag\r
+atag = HtmlSimpleTag\r
+noHtml = HtmlEmpty\r
+\r
+-- This is not processed for special chars. \r
+-- It is used to output them, though!\r
+primHtml = HtmlString\r
+\r
+------------------------------------------------------------------------------\r
+-- Useful Combinators\r
+\r
+concatHtml = foldr (+++) noHtml\r
+-- Processing Strings into Html friendly things.\r
+-- This converts a string to an Html.\r
+htmlStr = primHtml . htmlizeStr\r
+\r
+-- This converts a string, but keeps spaces as non-line-breakable\r
+htmlLine = primHtml . concat . map htmlizeChar2\r
+ where \r
+ htmlizeChar2 ' ' = " "\r
+ htmlizeChar2 c = htmlizeChar c\r
+\r
+-- Local Utilites\r
+htmlizeStr :: String -> String\r
+htmlizeStr = concat . map htmlizeChar\r
+\r
+htmlizeChar :: Char -> String\r
+htmlizeChar '<' = ">"\r
+htmlizeChar '>' = "<"\r
+htmlizeChar '&' = "&amb;"\r
+htmlizeChar '"' = """\r
+htmlizeChar c = [c]\r
+\r
+------------------------------------------------------------------------------\r
+-- Html Constructors\r
+h n = tag ("h" ++ show n)\r
+\r
+-- Isn't Haskell great!\r
+[h1,h2,h3,h4,h5,h6] = map h [1..6]\r
+\r
+-- tags\r
+font = tag "font"\r
+bold = tag "b"\r
+anchor = tag "a"\r
+header = tag "header"\r
+body = tag "body"\r
+theTitle = tag "title"\r
+paragraph = tag "p"\r
+italics = tag "i"\r
+ul = tag "ul"\r
+tt = tag "tt"\r
+\r
+bar = atag "hr"\r
+meta = atag "meta"\r
+li = atag "li"\r
+\r
+------------------------------------------------------------------------------\r
+-- Html Attributes\r
+\r
+-- note: the string is presumed to be formated for output\r
+--str :: String -> String -> HtmlAttr\r
+str n s = (n,Right s)\r
+\r
+--int :: String -> Int -> HtmlAttr\r
+int n v = (n,Left v)\r
+\r
+--percent :: String -> Int -> HtmlAttr\r
+percent n v = str n (show v ++ "%")\r
+\r
+-- attributes\r
+color = str "color"\r
+bgcolor = str "bgcolor"\r
+href = str "href"\r
+name = str "name"\r
+title = str "tile"\r
+height = str "height" \r
+width = str "width"\r
+align = str "align"\r
+valign = str "valign"\r
+\r
+border = int "border" \r
+size = int "size"\r
+cellpadding = int "cellpadding"\r
+cellspacing = int "cellspacing"\r
+\r
+------------------------------------------------------------------------------\r
+-- abbriviations\r
+p = paragraph []\r
+hr = atag "hr" []\r
+copyright = primHtml "©"\r
+spaceHtml = primHtml " "\r
+\r
+------------------------------------------------------------------------------\r
+-- Rendering\r
+\r
+renderHtml html = renderHtml' html (Just 0) ++ footerMessage\r
+\r
+footerMessage \r
+ = "\n<!-- Generated using the Haskell HTML generator package HaskHTML -->\n"\r
+\r
+renderHtml' (HtmlAppend html1 html2) d\r
+ = renderHtml' html1 d ++ renderHtml' html2 d\r
+renderHtml' (HtmlVerbatim html1) d\r
+ = renderHtml' html1 Nothing\r
+renderHtml' (HtmlEmpty) d = ""\r
+renderHtml' (HtmlSimpleTag name attr) d\r
+ = renderTag True name attr d\r
+renderHtml' (HtmlNestingTag name attr html) d\r
+ = renderTag True name attr d ++ renderHtml' html (incDepth d) ++\r
+ renderTag False name [] d\r
+renderHtml' (HtmlString str) _ = str\r
+\r
+incDepth :: Maybe Int -> Maybe Int\r
+incDepth = fmap (+4)\r
+\r
+-- This prints the tags in \r
+renderTag :: Bool -> HtmlName -> [HtmlAttr] -> Maybe Int -> String\r
+renderTag x name attrs n = start ++ base_spaces ++ open ++ name ++ rest attrs ++ ">"\r
+ where\r
+ open = if x then "<" else "</"\r
+ (start,base_spaces,sep) = case n of\r
+ Nothing -> ("",""," ")\r
+ Just n -> ("\n",replicate n ' ',"\n")\r
+ \r
+ rest [] = ""\r
+ rest [(tag,val)] = " " ++ tag ++ "=" ++ myShow val \r
+ rest (hd:tl) = " " ++ showPair hd ++ sep ++\r
+ foldr1 (\ x y -> x ++ sep ++ y)\r
+ [ base_spaces ++ replicate (1 + length name + 1) ' ' \r
+ ++ showPair p | p <- tl ]\r
+\r
+ showPair :: HtmlAttr -> String\r
+ showPair (tag,val) = tag ++ replicate (tagsz - length tag) ' ' ++ \r
+ " = " ++ myShow val \r
+ myShow (Left n) = show n\r
+ myShow (Right s) = "\"" ++ s ++ "\""\r
+\r
+ tagsz = maximum (map (length.fst) attrs)\r
+\r
+------------------------------------------------------------------------------\r
+-- Html table related things\r
+\r
+cellHtml attr html = OT.single cellFn\r
+ where\r
+ cellFn x y = tag "td" (addX x (addY y attr)) html\r
+ addX 1 rest = rest\r
+ addX n rest = int "colspan" n : rest\r
+ addY 1 rest = rest\r
+ addY n rest = int "rowspan" n : rest\r
+\r
+above = OT.above\r
+(+/+) = above\r
+beside = OT.beside\r
+(+-+) = beside\r
+\r
+{-\r
+ - Note: Both aboves and besides presume a non-empty list.\r
+ -}\r
+\r
+aboves = foldl1 (+/+)\r
+besides = foldl1 (+-+)\r
+\r
+-- renderTable takes the HtmlTable, and renders it back into\r
+-- and Html object. The attributes are added to the outside\r
+-- table tag.\r
+\r
+renderTable attr theTable\r
+ = table [row [theCell x y | (theCell,(x,y)) <- theRow ] \r
+ | theRow <- OT.getMatrix theTable]\r
+ where\r
+ row :: [Html] -> Html\r
+ row = tag "tr" [] . concatHtml\r
+\r
+ table :: [Html] -> Html\r
+ table = tag "table" attr . concatHtml\r
+\r
+-- If you cant be bothered with the above, then you\r
+-- can build simple tables with this.\r
+-- Just provide the attributes for the whole table,\r
+-- attributes for the cells (same for every cell),\r
+-- and a list of list of cell contents,\r
+-- and this function will build the table for you.\r
+-- It does presume that all the lists are non-empty,\r
+-- and there is at least one list.\r
+-- \r
+-- Different length lists means that the last cell\r
+-- gets padded. If you want more power, then\r
+-- use the system above.\r
+\r
+simpleTable attr cellAttr\r
+ = renderTable attr \r
+ . aboves\r
+ . map (besides . map (cellHtml cellAttr))\r
+\r
+ \r
+------------------------------------------------------------------------------\r
projects / ghc-hetmet.git / blobdiff