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