glafp-utils/nofib-analyse/DataHtml.hs

   1 -------------------------------------------------------------------------------\r
   2 -- $Id: DataHtml.hs,v 1.1 1999/11/12 11:54:17 simonmar Exp $\r
   3 --\r
   4 -- Copyright (c) 1999 Andy Gill\r
   5 -------------------------------------------------------------------------------\r
   6 \r
   7 module DataHtml (\r
   8         Html, HtmlName, HtmlAttr, HtmlTable,\r
   9         (+++), verbatim, {- tag, atag, -} noHtml, primHtml, \r
  10         concatHtml, htmlStr, htmlLine,\r
  11         h1,h2,h3,h4,h5,h6,      \r
  12         font, bold, anchor, header, body, theTitle, paragraph, italics,\r
  13         ul, tt,\r
  14         bar, meta, li,\r
  15         {- tr, int, percent -}\r
  16         color, bgcolor, href, name, title, height, width, align, valign,\r
  17         border, size, cellpadding, cellspacing,\r
  18         p, hr, copyright, spaceHtml, \r
  19         renderHtml, \r
  20         cellHtml, (+/+), above, (+-+), beside, aboves, besides,         \r
  21         renderTable, simpleTable, \r
  22         ) where\r
  23 \r
  24 import qualified OptTable as OT\r
  25 \r
  26 infixr 5 +++    -- appending Html\r
  27 infixr 3 +/+    -- combining HtmlTable\r
  28 infixr 4 +-+    -- combining HtmlTable\r
  29 \r
  30 data Html\r
  31         = HtmlAppend Html Html            -- Some Html, followed by more text\r
  32         | HtmlVerbatim Html               -- Turn on or off smart formating\r
  33         | HtmlEmpty                       -- Nothing!\r
  34         | HtmlNestingTag HtmlName [HtmlAttr] Html\r
  35         | HtmlSimpleTag  HtmlName [HtmlAttr]\r
  36         | HtmlString String\r
  37                 deriving (Show)\r
  38 \r
  39 {-\r
  40  - A important property of Html is all strings inside the\r
  41  - structure are already in Html friendly format.\r
  42  - For example, use of &gt;,etc.\r
  43  -}\r
  44 \r
  45 type HtmlName   = String\r
  46 type HtmlAttr   = (HtmlName,Either Int String)\r
  47 type HtmlTable  = OT.OptTable (Int -> Int -> Html)\r
  48 \r
  49 ------------------------------------------------------------------------------\r
  50 -- Interface\r
  51 ------------------------------------------------------------------------------\r
  52 \r
  53 -- primitive combinators\r
  54 (+++)           :: Html -> Html                 -> Html\r
  55 verbatim        :: Html                         -> Html\r
  56 tag             :: String -> [HtmlAttr] -> Html -> Html\r
  57 atag            :: String -> [HtmlAttr]         -> Html\r
  58 noHtml          ::                                 Html\r
  59 primHtml        :: String                       -> Html\r
  60 \r
  61 -- useful combinators\r
  62 concatHtml              :: [Html]                       -> Html\r
  63 htmlStr, htmlLine       :: String                       -> Html\r
  64 \r
  65 -- html constructors\r
  66 h1,h2,h3,h4,h5,h6       :: [HtmlAttr] -> Html           -> Html\r
  67 font, bold, anchor, \r
  68  header, body, \r
  69  theTitle, paragraph,\r
  70  italics, ul, tt        :: [HtmlAttr] -> Html           -> Html\r
  71 bar, meta, li           :: [HtmlAttr]                   -> Html\r
  72 \r
  73 -- html attributes\r
  74 str                     :: String -> String             -> HtmlAttr\r
  75 int                     :: String -> Int                -> HtmlAttr\r
  76 percent                 :: String -> Int                -> HtmlAttr\r
  77 \r
  78 color, bgcolor, href,\r
  79  name, title, height,\r
  80  width, align, valign   :: String                       -> HtmlAttr\r
  81 \r
  82 border, size,\r
  83  cellpadding,\r
  84  cellspacing            :: Int                          -> HtmlAttr \r
  85 \r
  86 -- abbriviations\r
  87 \r
  88 p                       :: Html                         -> Html\r
  89 hr                      ::                                 Html\r
  90 copyright               ::                                 Html\r
  91 spaceHtml               ::                                 Html\r
  92 \r
  93 -- rendering\r
  94 renderHtml              :: Html -> String\r
  95 \r
  96 -- html tables\r
  97 cellHtml                :: [HtmlAttr] -> Html           -> HtmlTable\r
  98 (+/+),above,\r
  99  (+-+),beside           :: HtmlTable -> HtmlTable       -> HtmlTable\r
 100 aboves, besides         :: [HtmlTable]                  -> HtmlTable\r
 101 renderTable             :: [HtmlAttr] -> HtmlTable      -> Html\r
 102 simpleTable             :: [HtmlAttr] -> [HtmlAttr] -> [[Html]] \r
 103                                                         -> Html\r
 104 \r
 105 ------------------------------------------------------------------------------\r
 106 -- Basic, primitive combinators\r
 107 \r
 108 -- This is intentionally lazy in the second argument.\r
 109 (HtmlAppend x y) +++ z = x +++ (y +++ z)\r
 110 (HtmlEmpty)      +++ z = z\r
 111 x                +++ z = HtmlAppend x z\r
 112 \r
 113 verbatim        = HtmlVerbatim\r
 114 tag             = HtmlNestingTag\r
 115 atag            = HtmlSimpleTag\r
 116 noHtml          = HtmlEmpty\r
 117 \r
 118 -- This is not processed for special chars. \r
 119 -- It is used to output them, though!\r
 120 primHtml        = HtmlString\r
 121 \r
 122 ------------------------------------------------------------------------------\r
 123 -- Useful Combinators\r
 124 \r
 125 concatHtml = foldr (+++) noHtml\r
 126 -- Processing Strings into Html friendly things.\r
 127 -- This converts a string to an Html.\r
 128 htmlStr = primHtml . htmlizeStr\r
 129 \r
 130 -- This converts a string, but keeps spaces as non-line-breakable\r
 131 htmlLine = primHtml . concat . map htmlizeChar2\r
 132    where \r
 133         htmlizeChar2 ' ' = "&nbsp;"\r
 134         htmlizeChar2 c   = htmlizeChar c\r
 135 \r
 136 -- Local Utilites\r
 137 htmlizeStr :: String -> String\r
 138 htmlizeStr = concat . map htmlizeChar\r
 139 \r
 140 htmlizeChar :: Char -> String\r
 141 htmlizeChar '<' = "&gt;"\r
 142 htmlizeChar '>' = "&lt;"\r
 143 htmlizeChar '&' = "&amb;"\r
 144 htmlizeChar '"' = "&quot;"\r
 145 htmlizeChar c   = [c]\r
 146 \r
 147 ------------------------------------------------------------------------------\r
 148 -- Html Constructors\r
 149 h n = tag ("h" ++ show n)\r
 150 \r
 151 -- Isn't Haskell great!\r
 152 [h1,h2,h3,h4,h5,h6] = map h [1..6]\r
 153 \r
 154 -- tags\r
 155 font            = tag "font"\r
 156 bold            = tag "b"\r
 157 anchor          = tag "a"\r
 158 header          = tag "header"\r
 159 body            = tag "body"\r
 160 theTitle        = tag "title"\r
 161 paragraph       = tag "p"\r
 162 italics         = tag "i"\r
 163 ul              = tag "ul"\r
 164 tt              = tag "tt"\r
 165 \r
 166 bar             = atag "hr"\r
 167 meta            = atag "meta"\r
 168 li              = atag "li"\r
 169 \r
 170 ------------------------------------------------------------------------------\r
 171 -- Html Attributes\r
 172 \r
 173 -- note: the string is presumed to be formated for output\r
 174 --str :: String -> String -> HtmlAttr\r
 175 str n s = (n,Right s)\r
 176 \r
 177 --int :: String -> Int -> HtmlAttr\r
 178 int n v = (n,Left v)\r
 179 \r
 180 --percent :: String -> Int -> HtmlAttr\r
 181 percent n v = str n (show v ++ "%")\r
 182 \r
 183 -- attributes\r
 184 color           = str "color"\r
 185 bgcolor         = str "bgcolor"\r
 186 href            = str "href"\r
 187 name            = str "name"\r
 188 title           = str "tile"\r
 189 height          = str "height" \r
 190 width           = str "width"\r
 191 align           = str "align"\r
 192 valign          = str "valign"\r
 193 \r
 194 border          = int "border" \r
 195 size            = int "size"\r
 196 cellpadding     = int "cellpadding"\r
 197 cellspacing     = int "cellspacing"\r
 198 \r
 199 ------------------------------------------------------------------------------\r
 200 -- abbriviations\r
 201 p               = paragraph []\r
 202 hr              = atag "hr" []\r
 203 copyright       = primHtml "&copy;"\r
 204 spaceHtml       = primHtml "&nbsp;"\r
 205 \r
 206 ------------------------------------------------------------------------------\r
 207 -- Rendering\r
 208 \r
 209 renderHtml html = renderHtml' html (Just 0) ++ footerMessage\r
 210 \r
 211 footerMessage \r
 212    = "\n<!-- Generated using the Haskell HTML generator package HaskHTML -->\n"\r
 213 \r
 214 renderHtml' (HtmlAppend html1 html2) d\r
 215         = renderHtml' html1 d ++ renderHtml' html2 d\r
 216 renderHtml' (HtmlVerbatim html1) d\r
 217         = renderHtml' html1 Nothing\r
 218 renderHtml' (HtmlEmpty) d = ""\r
 219 renderHtml' (HtmlSimpleTag name attr) d\r
 220         = renderTag True name attr d\r
 221 renderHtml' (HtmlNestingTag name attr html) d\r
 222         = renderTag True name attr d ++ renderHtml' html (incDepth d) ++\r
 223           renderTag False name [] d\r
 224 renderHtml' (HtmlString str) _ = str\r
 225 \r
 226 incDepth :: Maybe Int -> Maybe Int\r
 227 incDepth = fmap (+4)\r
 228 \r
 229 -- This prints the tags in \r
 230 renderTag :: Bool -> HtmlName -> [HtmlAttr] -> Maybe Int -> String\r
 231 renderTag x name attrs n = start ++ base_spaces ++ open ++ name ++ rest attrs ++ ">"\r
 232   where\r
 233         open = if x then "<" else "</"\r
 234         (start,base_spaces,sep) = case n of\r
 235                               Nothing -> ("",""," ")\r
 236                               Just n ->  ("\n",replicate n ' ',"\n")\r
 237                         \r
 238         rest []            = ""\r
 239         rest [(tag,val)]   = " " ++ tag ++ "=" ++ myShow val \r
 240         rest (hd:tl)       = " " ++ showPair hd ++ sep ++\r
 241                   foldr1 (\ x y -> x ++ sep ++ y)\r
 242                          [ base_spaces ++ replicate (1 + length name + 1) ' ' \r
 243                                 ++ showPair p | p <- tl ]\r
 244 \r
 245         showPair :: HtmlAttr -> String\r
 246         showPair (tag,val) = tag ++ replicate (tagsz - length tag) ' ' ++ \r
 247                         " = " ++ myShow val \r
 248         myShow (Left n) = show n\r
 249         myShow (Right s) = "\"" ++ s ++ "\""\r
 250 \r
 251         tagsz = maximum (map (length.fst) attrs)\r
 252 \r
 253 ------------------------------------------------------------------------------\r
 254 -- Html table related things\r
 255 \r
 256 cellHtml attr html = OT.single cellFn\r
 257     where\r
 258         cellFn x y = tag "td" (addX x (addY y attr)) html\r
 259         addX 1 rest = rest\r
 260         addX n rest = int "colspan" n : rest\r
 261         addY 1 rest = rest\r
 262         addY n rest = int "rowspan" n : rest\r
 263 \r
 264 above   = OT.above\r
 265 (+/+)   = above\r
 266 beside  = OT.beside\r
 267 (+-+)   = beside\r
 268 \r
 269 {-\r
 270  - Note: Both aboves and besides presume a non-empty list.\r
 271  -}\r
 272 \r
 273 aboves = foldl1 (+/+)\r
 274 besides = foldl1 (+-+)\r
 275 \r
 276 -- renderTable takes the HtmlTable, and renders it back into\r
 277 -- and Html object. The attributes are added to the outside\r
 278 -- table tag.\r
 279 \r
 280 renderTable attr theTable\r
 281         = table [row [theCell x y | (theCell,(x,y)) <- theRow ] \r
 282                         | theRow <- OT.getMatrix theTable]\r
 283    where\r
 284         row :: [Html] -> Html\r
 285         row  = tag "tr" [] . concatHtml\r
 286 \r
 287         table :: [Html] -> Html\r
 288         table = tag "table" attr . concatHtml\r
 289 \r
 290 -- If you cant be bothered with the above, then you\r
 291 -- can build simple tables with this.\r
 292 -- Just provide the attributes for the whole table,\r
 293 -- attributes for the cells (same for every cell),\r
 294 -- and a list of list of cell contents,\r
 295 -- and this function will build the table for you.\r
 296 -- It does presume that all the lists are non-empty,\r
 297 -- and there is at least one list.\r
 298 --  \r
 299 -- Different length lists means that the last cell\r
 300 -- gets padded. If you want more power, then\r
 301 -- use the system above.\r
 302 \r
 303 simpleTable attr cellAttr\r
 304         = renderTable attr \r
 305         . aboves\r
 306         . map (besides . map (cellHtml cellAttr))\r
 307 \r
 308         \r
 309 ------------------------------------------------------------------------------\r