src/Html.lhs

   1 \begin{code}
   2 -- Copyright 2008 the Contributors, as shown in the revision logs.
   3 -- Licensed under the Apache Public Source License 2.0 ("the License").
   4 -- You may not use this file except in compliance with the License.
   5
   6 module Html
   7 where
   8 import Edu_Berkeley_Sbp_Haskell_SBP
   9 import FromTree
  10 import Doc
  11 import List(isSuffixOf,isPrefixOf)
  12
  13 -- FIXME: use pretty-printing when asked to for better display
  14
  15 class ToHtml a where
  16   toHtml :: a -> String
  17 instance ToHtml a => ToHtml [a] where
  18   toHtml x = concatMap toHtml x
  19
  20 style =
  21   "\n<style>\n"++
  22   " h1, h2, h3, h4 { font-family: 'Trebuchet MS', arial, verdana, sans-serif; width: 100% }\n"++
  23   " h1 { font-size: 20pt; border-top: black 1px solid; }\n"++
  24   " h2 { font-size: 16pt; border-top: silver 1px solid; }\n"++
  25   " h3 { font-size: 12pt; }\n"++
  26   " TH, TD, P, LI, DIV, SPAN {\n"++
  27   "     font-family: verdana, arial, sans-serif;\n"++
  28   "     font-size: 12px;  \n"++
  29   "     text-decoration:none; \n"++
  30   " }\n"++
  31   " LI { margin-top: 5px; }\n"++
  32   " body { color: #333333; }\n"++
  33   " blockquote { font-style: italic; width: 100% }\n"++
  34   " div.warn { border: 1px solid #f44; border-top: 5px solid #f44; background-color: #fbb; color: white; }\n"++
  35   " td.warn { color: black; }\n"++
  36   " div.announce { border: 1px solid green; background-color: #bfb; color: white; }\n"++
  37   " td.announce { color: black; }\n"++
  38   " div.footer {\n"++
  39   "   color: gray;\n"++
  40   "   border-top: 1px solid silver;\n"++
  41   "   font-size: 10px;\n"++
  42   " }\n"++
  43   " table.blockquote { margin: 5px; border: 1px #e6ddcb solid; background-color: #fbf2e0; width: 100% }\n"++
  44   " a:link { text-decoration: none; color: blue; border-bottom:1px dotted; }\n"++
  45   " a:visited { text-decoration: none; color: purple; border-bottom:1px dotted; }\n"++
  46   " a:active { text-decoration: none; color: red; border-bottom:1px solid; }\n"++
  47   " a:hover { text-decoration: none; border-bottom:1px solid; }\n"++
  48   " table.footer { border-top: silver solid 1px; }\n"++
  49   " span.signature { color: #bbb;  }\n"++
  50   " .signature a:link { color: #aaf;  }\n"++
  51   " .signature a:visited { color: #faa;  }\n"++
  52   " .signature a:hover { color: blue; border-bottom: 1px solid blue;  }\n"++
  53   " span.highlight { background: yellow; color: black; padding: 3px }\n"++
  54   " div.pre {\n"++
  55   "     text-align: left;\n"++
  56   "     font-family: monospace;\n"++
  57   "     border-style: none;\n"++
  58   "     border-width: 2px 2px 2px 2px;\n"++
  59   "     border-color: #6666aa;\n"++
  60   "     color: #FFFFFF;\n"++
  61   "     background-color: #333333;\n"++
  62   "     margin-right: 25px;\n"++
  63   "     margin-left: 25px;\n"++
  64   "     padding: 10px;\n"++
  65   "  }\n"++
  66   "</style>\n"
  67
  68
  69 instance ToHtml Doc where
  70  toHtml (Doc h secs) =
  71      "<!-- This document was AUTOMATICALLY GENERATED from wix source -->\n"++
  72      "<!--    it is probably not a wise idea to edit it directly     -->\n\n"++
  73      "<html>\n"++
  74      "<head>\n"++
  75      style++
  76      --FIXME: title tag
  77      "</head>\n"++
  78      "<body>\n"++   -- tell jsmath we will escape stuff manually
  79
  80      -- FIXME: only put this in if math appears on the page
  81      "<script> jsMath = { showFontWarnings: false } </script>\n"++
  82      "<script src='/jsmath/easy/load.js'></script>\n"++
  83      "<span id='tex2math_off'></span>\n"++
  84      "<NOSCRIPT> <DIV STYLE='color:#CC0000; text-align:center'> <B>Warning: <A HREF='http://www.math.union.edu/locate/jsMath'>jsMath</A> requires JavaScript to process the mathematics on this page.<BR> If your browser supports JavaScript, be sure it is enabled.</B> </DIV> <HR> </NOSCRIPT>\n"++
  85
  86      "<center><table><tr><td width=600>\n"++
  87      (toHtml secs) ++
  88      "<br><br>\n"++
  89      "<table width=100% class=footer><tr><td align=left>"++
  90      "<img src='"++printIconBase64++"'></td>"++
  91      "<td align=right><span class='signature'>rendered from "++
  92      "<a href=http://www.megacz.com/software/wix>"++
  93      "W<span style='vertical-align:-20%'>I</span>X</a></span></div></td></tr></table>\n"++
  94      "</td></tr></table></center>\n"++
  95      "</body></html>"
  96
  97 quoteIconBase64 =
  98     "data:image/png;base64,"
  99     ++"iVBORw0KGgoAAAANSUhEUgAAABAAAAAVCAYAAABPPm7SAAAABmJLR0QA/wD/AP+gvaeTAAAA"
 100     ++"CXBIWXMAAAsTAAALEwEAmpwYAAAAB3RJTUUH1wQPAx0rP5obpAAAAWJJREFUOMvdlKFvg0AU"
 101     ++"xr8tVZ1cbU+04lUuwc2WypMX9AxiomoJ/RNYqmaaYKpb5kBys1UkWBCdKLqVs8zwFnrQmYol"
 102     ++"+xLC8X55H/e+wAENhWGoPM/zT6eThQ4lSWJf5EEQuAAqAJXv+95vXCkVtpwZuq4bmM1pmlrM"
 103     ++"LctKWzuwbTsBUNX3lph3Njfd6/WZ9vv9iHkYhsrkPa21zQ9aa9v3fRsAFovFK9cMPgIApdT7"
 104     ++"eDz+RB1Y1XEBwEVe54ZbXKm/N7haNwCQ5zmtVqtnE0op49lspgFgPp+/dfF/EGIPAAaDgZBS"
 105     ++"xgBwPB7vd7vdIwD0+/2v5ry8juNYmgY/P1GWZQ9sQER3XOcwD4fDkA2IqGiNwN8+ERVNY/Pt"
 106     ++"RFQIIcozg+Vy+VKW5dDcMmuz2ThFURAATKfTj7MQ1+v1Ezc7jrMVQpTmocOjOY6znUwmRSvR"
 107     ++"KIpknud0KfEoimSWZQ/N2jfhtb1AvGklDQAAAABJRU5ErkJggg=="
 108
 109 warnIconBase64 =
 110     "data:image/png;base64,"
 111     ++"iVBORw0KGgoAAAANSUhEUgAAABQAAAAREAYAAACN1FD9AAAABmJLR0QA/wD/AP+gvaeTAAAA"
 112     ++"CXBIWXMAAABIAAAASABGyWs+AAAACXZwQWcAAAAUAAAAEQDeTN6UAAAD/ElEQVRIx8WUbUyV"
 113     ++"ZRjHf+chxDi8yZcDa0mKh/wSuNE5eNYHZBiRwoespayEkdgx22hmjB1glTlenDYlMccAX1cb"
 114     ++"CDFlg+aQ1JGEazGWpixdbbweDucctPF2PNxXX3pw00gL09+X59m1+77+v+d+nueCBRJ+ECAs"
 115     ++"78dnAPp2nLEDtMdpPwMYZhfaf8GU1gLsixwdBRDRr7lRAHmxT0zs+UKAuKmhXgDfGleAYZVh"
 116     ++"lXynC/Z1AYyeX+IFiLjw+MwWAxDQuBqgNVsX+iNta/nWcnV0vD+9Ir1CndDre68AfDH42PzW"
 117     ++"2QDW79UFxkxh6WHp8o5a5lznXCfJ/nPX867nSYArO7AssEyOjOwE8GfGZwC84Pu3edrDLgzK"
 118     ++"AFj06q7DAPt/1evBK4szizMlpXy4tqO2g/MHa9sm2ibwP23M78zvFE0rBAg4U24DqFpieAqA"
 119     ++"6kd+cjuiAAqu6Sfn/n55/fJ6CZOc6YHpATmkNWgNWoOIZtSMmlFE1d9ae2utvDt21ZRiSpHV"
 120     ++"+r43LwFkBT4ysehigKgDvxcC3P5QD5qxNtU11anj8hfhg+GD4YMixipjlbFK5pjyHok8Enn3"
 121     ++"m7yyG2DAEdIFYLy9YMHDLoBjK/WA8fhkb7JXtcqMnJbT4tJFYlpiWmJaRKJio2KjYu8KSp9K"
 122     ++"UAly2ZtpSbWkql/0PrsuAJR3/2cx65cA1qujRgBV6HpWy9fy5dydOz2JPYlqQO4hwZ/gT/CL"
 123     ++"mB1mh9kh93Enq2tP1x7V4wo0pBnS5KehVwBmPjA7AcxtDy2mBQIYPmk/B/CDb26MxGw5teWU"
 124     ++"+krmIdWaak21iiR2JHYkdsi83G7KtmRb1HG9b+PHAK2lJAEQ9EDBt88C5BybGyOLQgtCC8Su"
 125     ++"gkesI1axzRd8Mvdk7slckeoN1RuqN8wvODsyVDNUIxaXP0SFKHlfz8l4GSDTfd+B6Tdh5QCh"
 126     ++"hUUvAlR8o9eDI4qSipLkJcOEqdvUzaX5HmzSNGmaNMFN+037TTvgxInzb96QKTovOo/LRmuJ"
 127     ++"r8QnFr3+2esAB/IX9wAEjd+3cfc+gD2euTFSv2zzss0SIdnTG6c3SqU8AFulrdJWKRJSElIS"
 128     ++"UiLia/Y1+5r/YcNHM9tntku1e2KFZ4VHAvXcwnyAksY5MfNvAOYdQ+8BzHytL5warDtRd2I2"
 129     ++"QjWNh46HqjR11LvGu0aVqUOei56LYlD7PRWeCmlWpe4p95R87h66Yb9hV+7+o71BvUHKoWyj"
 130     ++"jlGHSlbPOTc5N6kkFTqybWSbeksxfHb4rGqd9Q3nDOdI5lRHTXtNu6rWc/vfAJjoXHoNYOl6"
 131     ++"Q70CaFEpYwAZhof+m/5nvv0UoDFLW/UagCXuSQvdSzwAiTv/BGXg1AxNKyCeAAAAAElFTkSu"
 132     ++"QmCC"
 133
 134 printIconBase64 =
 135     "data:image/png;base64,"
 136     ++"iVBORw0KGgoAAAANSUhEUgAAAA8AAAAOCAMAAADHVLbdAAAALHRFWHRDcmVhdGlvbiBUaW1l"
 137     ++"AEZyaSAxOSBTZXAgMjAwMyAxODozOTozMiAtMDAwME2jAt8AAAAHdElNRQfTCRMRKABXeznM"
 138     ++"AAAACXBIWXMAAAsSAAALEgHS3X78AAAABGdBTUEAALGPC/xhBQAAACRQTFRF////AAAA7+/v"
 139     ++"3t7ezs7OtbW1ra2tlJSUnJycEBAQKSkphISEbGtEogAAAAF0Uk5TAEDm2GYAAABLSURBVHja"
 140     ++"nY1BEsAgCAMDKm31//81qB3l6h4Y4mYQQNvAmXNv7W/gytcTRj6pppQHNWoW6JWS13Ix86yr"
 141     ++"O7MEPkDWuWLPK/7hoYEOxksDsk8eppEAAAAASUVORK5CYII="
 142
 143
 144 emailIconBase64 =
 145     "data:image/png;base64,"
 146     ++"iVBORw0KGgoAAAANSUhEUgAAABUAAAAOCAMAAAD32Kf8AAAALHRFWHRDcmVhdGlvbiBUaW1l"
 147     ++"AEZyaSAxOSBTZXAgMjAwMyAxODo0MjowOSAtMDAwMBDwv7IAAAAHdElNRQfTCRMRKhqYL6I0"
 148     ++"AAAACXBIWXMAAAsSAAALEgHS3X78AAAABGdBTUEAALGPC/xhBQAAADBQTFRF////AAAAhISE"
 149     ++"9/fv9/f3////CAgI7+/v1tbOxsa9tbWtpaWclJSMlJSUe3t7a2trxDv8WgAAAAF0Uk5TAEDm"
 150     ++"2GYAAABiSURBVHjabc9JEoAgDETRpNOKs/e/rSEYF8jfhHpQFAi6JHpHBg5VOdIj+KeXkgO9"
 151     ++"tUj/Bldo3WdRnktt3fbjgoWKK5EKsunkyryCn86Oxsj/UZqKEkFmNF+mvieFdSK16wFr7QK5"
 152     ++"tASqkwAAAABJRU5ErkJggg=="
 153
 154 pdfIconBase64 =
 155     "data:image/png;base64,"
 156     ++"iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAMAAAAoLQ9TAAAAK3RFWHRDcmVhdGlvbiBUaW1l"
 157     ++"AFRodSA2IE5vdiAyMDAzIDE1OjMwOjAwIC0wMDAwSwt8PwAAAAd0SU1FB9MLBg8fD1x8/t4A"
 158     ++"AAAJcEhZcwAACxIAAAsSAdLdfvwAAAAEZ0FNQQAAsY8L/GEFAAAAQlBMVEX///9zc3Nra2uE"
 159     ++"hITGxsaUlJScnJx7e3uMjIz////39/fv7+/n5+fe3t69vb1jY2OlpaXW1ta1tbVaWlqtra3O"
 160     ++"zs5w48BYAAAAAXRSTlMAQObYZgAAAIdJREFUeNpNz1ESBBEMBNCRwSCJMOT+V10WW9vKz6uO"
 161     ++"iusa0R137ShxjImwHsnSMCbEX6dPiIje+SUKC6hav8CbAQlZD/RmJ1Tdz6oTwETMfAByK0hT"
 162     ++"1kgH7E1phFfjdvS2JlJpN8RAyEHMhgJgaexJTBPyA1JiGoD0BXgg2H8wcFs3/jDvPB+sOwir"
 163     ++"+o6iKQAAAABJRU5ErkJggg=="
 164
 165 instance ToHtml Section where
 166  toHtml (Section level header paragraphs) =
 167      "\n<h"++(show (level+1))++">\n"++
 168      (toHtml header)++
 169      "\n</h"++(show (level+1))++">\n"++
 170      (toHtml paragraphs)
 171 stag t body = "\n<"++t++">\n"++body++"\n</"++t++">\n"
 172 tag  t body = "<"++t++">"++body++"</"++t++">"
 173
 174 instance ToHtml Paragraph where
 175  toHtml (Blockquote t) = "\n<table class=blockquote border=0 cellpadding=5px>\n"
 176                          ++"<tr><td valign=top><image src='"++quoteIconBase64++"'></td>\n"
 177                          ++"<td class=warn>\n"
 178                          ++(toHtml t)
 179                          ++"</td></tr></table>\n"
 180  toHtml HR             = stag "hr" []
 181  toHtml (OL t)         = stag "ol" $ concatMap (\x -> stag "li" $ concatMap toHtml x) t
 182  toHtml (UL t)         = stag "ul" $ concatMap (\x -> stag "li" $ concatMap toHtml x) t
 183  toHtml (P t)          = stag "p"  $ toHtml t
 184
 185
 186 link ref body = "<a href='"++ref++"'>"++icon++body++"</a>"
 187  where
 188   icon = if      ".pdf" `isSuffixOf` ref then "<img "++img++" src='"++pdfIconBase64++"'>&nbsp;"
 189          else if "mailto:" `isPrefixOf` ref then "<img "++img++" src='"++emailIconBase64++"'>&nbsp;"
 190          else ""
 191   img = "style='vertical-align: text-bottom;' border=0 "
 192 -- margin-bottom: -2px; padding-bottom: 2px;  border-bottom: 1px blue solid;
 193
 194 instance ToHtml Text where
 195  toHtml WS                        = " "
 196  toHtml (Chars s)                 = toHtml s
 197
 198  -- directional quotes: see http://www.dwheeler.com/essays/quotes-in-html.html
 199  toHtml (Quotes x)                = "&#8220;"++(toHtml x)++"&#8221;"
 200  toHtml (Verbatim x)              = pre x
 201  toHtml (Link t ref)              = link (show ref) (toHtml t)
 202  toHtml (Command "comment" y)     = ""
 203  toHtml (Command "url" y)         = "<tt>"++(link (toHtml y) (toHtml y))++"</tt>"
 204  toHtml (Command "WiX" y)         = "W<span style='vertical-align:-20%'>I</span>X"
 205  toHtml (Command "TeX" y)         = "T<span style='vertical-align:-20%'>E</span>X"
 206 --   u'1/2' : u'\u00BD',
 207 --    u'1/4' : u'\u00BC',
 208 --    u'3/4' : u'\u00BE',
 209 --    u'1/3' : u'\u2153',
 210 --    u'2/3' : u'\u2154',
 211 --    u'1/5' : u'\u2155',
 212 --    u'2/5' : u'\u2156',
 213 --    u'3/5' : u'\u2157',
 214 --    u'4/5' : u'\u2158',
 215 --    u'1/6' : u'\u2159',
 216 --    u'5/6' : u'\u215A',
 217 --    u'1/8' : u'\u215B',
 218 --    u'3/8' : u'\u215C',
 219 --    u'5/8' : u'\u215D',
 220 --    u'7/8' : u'\u215E',
 221
 222  toHtml (Styled Underline x)      = tag "u" $ toHtml x
 223  toHtml (Styled TT x)             = tag "tt" $ toHtml x
 224  toHtml (Styled Italic x)         = tag "i" $ toHtml x
 225  toHtml (Styled Strikethrough x)  = tag "strike" $ toHtml x
 226  toHtml (Styled Superscript x)    = tag "sup" $ toHtml x
 227  toHtml (Styled Subscript x)      = tag "sub" $ toHtml x
 228  toHtml (Styled Bold x)           = tag "b" $ toHtml x
 229  toHtml (Styled Highlight x)      = "<span class=highlight>"++(toHtml x)++"</span>"
 230
 231  toHtml (Keyword x)               = tag "tt" $ toHtml x
 232  toHtml (SubPar x)                = stag "p" $ concatMap toHtml x
 233
 234  toHtml (Command "red" y)         = "<font color=red>"++(toHtml y)++"</font>"
 235  toHtml (Command "orange" y)      = "<font color=orange>"++(toHtml y)++"</font>"
 236  toHtml (Command "green" y)       = "<font color=green>"++(toHtml y)++"</font>"
 237  toHtml (Command "sc" y)          = "<sc>"++(toHtml y)++"</sc>"
 238  toHtml (Command "image" y)       = "<img src='"++(toHtml y)++"'/>"
 239  toHtml (Command "imagec" y)      = "<center><img src='"++(toHtml y)++"'/></center>"
 240  toHtml (Command "image2" y)      = "<img width=180px src='"++(toHtml y)++"'/>"
 241  toHtml (Command "image3" y)      = "<img width=200px src='"++(toHtml y)++"'/>"
 242  toHtml (Command "image4" y)      = "<center><img width=550px src='"++(toHtml y)++"'/></center>"
 243  toHtml (Command "warn" y)        = "\n<div class=warn>\n<table border=0 cellpadding=5px>\n"
 244                                     ++"<tr><td valign=top><image src='"++warnIconBase64++"'></td>\n"
 245                                     ++"<td class=warn>\n"
 246                                     ++(toHtml y)
 247                                     ++"</td></tr></table></div>\n"
 248  toHtml (Command "announce" y)    = "\n<div class=announce>\n<table border=0 cellpadding=5px>\n"
 249                                     ++"<tr><td valign=top></td>\n"
 250                                     ++"<td class=warn>\n"
 251                                     ++(toHtml y)
 252                                     ++"</td></tr></table></div>\n"
 253  toHtml (Command "br" _)          = "\n<br/>\n"
 254  toHtml (Command "cent" _)        = "&#189;"
 255  toHtml (Command "euro" _)        = "&#8364;"
 256
 257  -- gross hack
 258  toHtml (Command "ordinal" x) | (last (toHtml x) == '1') = (toHtml x)++"<sup>"++"st"++"</sup>"
 259                               | (last (toHtml x) == '2') = (toHtml x)++"<sup>"++"nd"++"</sup>"
 260                               | (last (toHtml x) == '3') = (toHtml x)++"<sup>"++"rd"++"</sup>"
 261                               | otherwise                = (toHtml x)++"<sup>"++"th"++"</sup>"
 262
 263  -- FIXME: use "unicode vulgar fractions" here
 264  toHtml (Command "fraction" [n,d]) = "<sup>"++(toHtml n)++"</sup>"++"/"++"<sub>"++(toHtml d)++"</sub>"
 265  toHtml (Command "rfc" x)         = "<tt><a href=http://tools.ietf.org/html/rfc"++(toHtml x)++">RFC"++(toHtml x)++"</a></tt>"
 266
 267  -- FIXME: add div as well (for display-mode math)
 268  toHtml (Math m)                  = "<span class=math>" ++ (toHtml m) ++ "</span>"
 269  toHtml (Footnote x)              = error $ "footnotes not supported"
 270
 271  toHtml (GlyphText Euro)          = "&#8364;"
 272  toHtml (GlyphText CircleR)       = "&#162;"
 273  toHtml (GlyphText CircleC)       = "&#174;"
 274  toHtml (GlyphText TradeMark)     = "&#8482;"
 275  toHtml (GlyphText ServiceMark)   = "&#8482;"
 276  toHtml (GlyphText Emdash)        = "&mdash;"
 277  toHtml (GlyphText Ellipsis)      = "&#0133;"  -- &cdots;?
 278  toHtml (GlyphText Cent)          = "&#189;"
 279  toHtml (GlyphText Daggar)        = "&#8224;"
 280  toHtml (GlyphText DoubleDaggar)  = "&#8225;"
 281  toHtml (GlyphText Clover)        = "&#8984;"
 282  toHtml (GlyphText Flat)          = "&#8918;"
 283  toHtml (GlyphText Natural)       = "&#8919;"
 284  toHtml (GlyphText Sharp)         = "&#8920;"
 285  toHtml (GlyphText CheckMark)     = "&#10003;"
 286  toHtml (GlyphText XMark)         = "&#10007;"
 287  toHtml (GlyphText LeftArrow)            = "&larr;"
 288  toHtml (GlyphText RightArrow)           = "&rarr;"
 289  toHtml (GlyphText DoubleLeftArrow)      = "&#;"  -- FIXME
 290  toHtml (GlyphText DoubleRightArrow)     = "&#;"  -- FIXME
 291  toHtml (GlyphText DoubleLeftRightArrow) = "&#;"  -- FIXME
 292  toHtml (GlyphText LeftRightArrow)       = "&#;"  -- FIXME
 293  toHtml (GlyphText Degree)               = "&#;"  -- FIXME
 294
 295  toHtml (Command ('k':'e':'y':'s':'t':'r':'o':'k':'e':':':k) _) =
 296      "&#x"++(case k of
 297                "command" -> "2318"
 298                "shift" -> "21E7"
 299                "option" -> "2325"
 300                "control" -> "2303"
 301                "capslock" -> "21EA"
 302                "apple" -> "F8FF"
 303                )++";"
 304  toHtml (Command x y)             = error $ "unsupported command "++(show x)
 305
 306 instance ToHtml String where
 307   toHtml s = concatMap htmlEscapeChar s
 308
 309 htmlEscapeChar '<'  = "&lt;"
 310 htmlEscapeChar '>'  = "&gt;"
 311 htmlEscapeChar '&'  = "&amp;"
 312 htmlEscapeChar '\'' = "&apos;"
 313 htmlEscapeChar '\"' = "&quot;"
 314 htmlEscapeChar c    = [c]
 315
 316 pre x = "\n<div class=pre style='white-space:nowrap'>"++ (pre' x) ++ "\n</div>\n"
 317  where
 318   pre' (' ':b)         = "&nbsp;"++(pre' b)
 319   pre' ('\n':b)        = "<br/>\n"++(pre' b)
 320   pre' (a:b)           = (htmlEscapeChar a)++(pre' b)
 321   pre' []              = []
 322 \end{code}