glafp-utils/nofib-analyse/DataHtml.hs

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