src/Html.lhs

   1 \begin{code}
   2 module Html
   3 where
   4 import SBP
   5 import FromTree
   6 import Doc
   7 import List(isSuffixOf,isPrefixOf)
   8
   9 -- FIXME: use pretty-printing when asked to for better display
  10
  11 class ToHtml a where
  12   toHtml :: a -> String
  13 instance ToHtml a => ToHtml [a] where
  14   toHtml x = concatMap toHtml x
  15
  16 style =
  17   "\n<style>\n"++
  18   " h1, h2, h3, h4 { font-family: 'Trebuchet MS', arial, verdana, sans-serif; width: 100% }\n"++
  19   " h1 { font-size: 20pt; border-top: black 1px solid; }\n"++
  20   " h2 { font-size: 16pt; border-top: silver 1px solid; }\n"++
  21   " h3 { font-size: 12pt; }\n"++
  22   " TH, TD, P, LI, DIV, SPAN {\n"++
  23   "     font-family: verdana, arial, sans-serif;\n"++
  24   "     font-size: 12px;  \n"++
  25   "     text-decoration:none; \n"++
  26   " }\n"++
  27   " LI { margin-top: 5px; }\n"++
  28   " body { color: #333333; }\n"++
  29   " blockquote { font-style: italic; width: 100% }\n"++
  30   " div.warn { border: 1px solid red; background-color: #fbb; color: white; }\n"++
  31   " td.warn { color: black; }\n"++
  32   " div.announce { border: 1px solid green; background-color: #bfb; color: white; }\n"++
  33   " td.announce { color: black; }\n"++
  34   " div.footer {\n"++
  35   "   color: gray;\n"++
  36   "   border-top: 1px solid silver;\n"++
  37   "   font-size: 10px;\n"++
  38   " }\n"++
  39   " table.blockquote { margin: 5px; border: 1px #e6ddcb solid; background-color: #fbf2e0; width: 100% }\n"++
  40   " a:link { text-decoration: none; color: blue; border-bottom:1px dotted; }\n"++
  41   " a:visited { text-decoration: none; color: purple; border-bottom:1px dotted; }\n"++
  42   " a:active { text-decoration: none; color: red; border-bottom:1px solid; }\n"++
  43   " a:hover { text-decoration: none; border-bottom:1px solid; }\n"++
  44   " table.footer { border-top: silver solid 1px; }\n"++
  45   " span.signature { color: #bbb;  }\n"++
  46   " .signature a:link { color: #bbb;  }\n"++
  47   " .signature a:visited { color: #bbb;  }\n"++
  48   " .signature a:hover { color: blue; border-bottom: 1px solid blue;  }\n"++
  49   " span.highlight { background: yellow; color: black; padding: 3px }\n"++
  50   " div.pre {\n"++
  51   "     text-align: left;\n"++
  52   "     font-family: monospace;\n"++
  53   "     border-style: solid;\n"++
  54   "     border-width: 2px 2px 2px 2px;\n"++
  55   "     border-color: #6666aa;\n"++
  56   "     color: #FFFFFF;\n"++
  57   "     background-color: #000000;\n"++
  58   "     margin-right: 25px;\n"++
  59   "     margin-left: 25px;\n"++
  60   "     padding: 10px;\n"++
  61   "  }\n"++
  62   "</style>\n"
  63
  64
  65 instance ToHtml Doc where
  66  toHtml (Doc h secs) =
  67      "<!-- This document was AUTOMATICALLY GENERATED from wix source -->\n"++
  68      "<!--    it is probably not a wise idea to edit it directly     -->\n\n"++
  69      "<html>\n"++
  70      "<head>\n"++
  71      style++
  72      --FIXME: title tag
  73      "</head>\n"++
  74      "<body>\n"++   -- tell jsmath we will escape stuff manually
  75
  76      -- FIXME: only put this in if math appears on the page
  77      "<script> jsMath = { showFontWarnings: false } </script>\n"++
  78      "<script src='/jsmath/easy/load.js'></script>\n"++
  79      "<span id='tex2math_off'></span>\n"++
  80      "<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"++
  81
  82      "<center><table><tr><td width=600>\n"++
  83      (toHtml secs) ++
  84      "<br><br>\n"++
  85      "<table width=100% class=footer><tr><td align=left>"++
  86      "<img src=/images/print.icon.png></td>"++
  87      "<td align=right><span class='signature'>rendered from "++
  88      "<a href=http://www.megacz.com/software/wix>"++
  89      "W<span style='vertical-align:-20%'>I</span>X</a></span></div></td></tr></table>\n"++
  90      "</td></tr></table></center>\n"++
  91      "</body></html>"
  92
  93 instance ToHtml Section where
  94  toHtml (Section level header paragraphs) =
  95      "\n<h"++(show (level+1))++">\n"++
  96      (toHtml header)++
  97      "\n</h"++(show (level+1))++">\n"++
  98      (toHtml paragraphs)
  99 stag t body = "\n<"++t++">\n"++body++"\n</"++t++">\n"
 100 tag  t body = "<"++t++">"++body++"</"++t++">"
 101
 102 instance ToHtml Paragraph where
 103  toHtml (Blockquote t) = "\n<table class=blockquote border=0 cellpadding=5px>\n"
 104                          ++"<tr><td valign=top><image src=/images/blockquote.png></td>\n"
 105                          ++"<td class=warn>\n"
 106                          ++(toHtml t)
 107                          ++"</td></tr></table>\n"
 108  toHtml HR             = stag "hr" []
 109  toHtml (OL t)         = stag "ol" $ concatMap (\x -> stag "li" $ concatMap toHtml x) t
 110  toHtml (UL t)         = stag "ul" $ concatMap (\x -> stag "li" $ concatMap toHtml x) t
 111  toHtml (P t)          = stag "p"  $ toHtml t
 112
 113
 114 link ref body = "<a href='"++ref++"'>"++icon++body++"</a>"
 115  where
 116   icon = if      ".pdf" `isSuffixOf` ref then "<img "++img++" src=/images/pdf.icon.png>&nbsp;"
 117          else if "mailto:" `isPrefixOf` ref then "<img "++img++" src=/images/email.icon.png>&nbsp;"
 118          else ""
 119   img = "style='vertical-align: text-bottom;' border=0 "
 120 -- margin-bottom: -2px; padding-bottom: 2px;  border-bottom: 1px blue solid;
 121
 122 instance ToHtml Text where
 123  toHtml WS                        = " "
 124  toHtml (Chars s)                 = toHtml s
 125
 126  -- directional quotes: see http://www.dwheeler.com/essays/quotes-in-html.html
 127  toHtml (Quotes x)                = "&#8220;"++(toHtml x)++"&#8221;"
 128  toHtml (Verbatim x)              = pre x
 129  toHtml (Link t ref)              = link (show ref) (toHtml t)
 130  toHtml (Command "url" y)         = "<tt>"++(link (toHtml y) (toHtml y))++"</tt>"
 131  toHtml (Command "WiX" y)         = "W<span style='vertical-align:-20%'>I</span>X"
 132  toHtml (Command "TeX" y)         = "T<span style='vertical-align:-20%'>E</span>X"
 133 --   u'1/2' : u'\u00BD',
 134 --    u'1/4' : u'\u00BC',
 135 --    u'3/4' : u'\u00BE',
 136 --    u'1/3' : u'\u2153',
 137 --    u'2/3' : u'\u2154',
 138 --    u'1/5' : u'\u2155',
 139 --    u'2/5' : u'\u2156',
 140 --    u'3/5' : u'\u2157',
 141 --    u'4/5' : u'\u2158',
 142 --    u'1/6' : u'\u2159',
 143 --    u'5/6' : u'\u215A',
 144 --    u'1/8' : u'\u215B',
 145 --    u'3/8' : u'\u215C',
 146 --    u'5/8' : u'\u215D',
 147 --    u'7/8' : u'\u215E',
 148
 149  toHtml (Styled Underline x)      = tag "u" $ toHtml x
 150  toHtml (Styled TT x)             = tag "tt" $ toHtml x
 151  toHtml (Styled Italic x)         = tag "i" $ toHtml x
 152  toHtml (Styled Strikethrough x)  = tag "strike" $ toHtml x
 153  toHtml (Styled Superscript x)    = tag "sup" $ toHtml x
 154  toHtml (Styled Subscript x)      = tag "sub" $ toHtml x
 155  toHtml (Styled Bold x)           = tag "b" $ toHtml x
 156  toHtml (Styled Highlight x)      = "<span class=highlight>"++(toHtml x)++"</span>"
 157
 158  toHtml (Keyword x)               = tag "tt" $ toHtml x
 159  toHtml (SubPar x)                = stag "p" $ concatMap toHtml x
 160
 161  toHtml (Command "red" y)         = "<font color=red>"++(toHtml y)++"</font>"
 162  toHtml (Command "orange" y)      = "<font color=orange>"++(toHtml y)++"</font>"
 163  toHtml (Command "green" y)       = "<font color=green>"++(toHtml y)++"</font>"
 164  toHtml (Command "sc" y)          = "<sc>"++(toHtml y)++"</sc>"
 165  toHtml (Command "image" y)       = "<img src='"++(toHtml y)++"'/>"
 166  toHtml (Command "image3" y)      = "<img width=200px src='"++(toHtml y)++"'/>"
 167  toHtml (Command "image4" y)      = "<center><img width=550px src='"++(toHtml y)++"'/></center>"
 168  toHtml (Command "warn" y)        = "\n<div class=warn>\n<table border=0 cellpadding=5px>\n"
 169                                     ++"<tr><td valign=top><image src=/images/warn.png></td>\n"
 170                                     ++"<td class=warn>\n"
 171                                     ++(toHtml y)
 172                                     ++"</td></tr></table></div>\n"
 173  toHtml (Command "announce" y)    = "\n<div class=announce>\n<table border=0 cellpadding=5px>\n"
 174                                     ++"<tr><td valign=top></td>\n"
 175                                     ++"<td class=warn>\n"
 176                                     ++(toHtml y)
 177                                     ++"</td></tr></table></div>\n"
 178  toHtml (Command "br" _)          = "\n<br/>\n"
 179  toHtml (Command "cent" _)        = "&#189;"
 180  toHtml (Command "euro" _)        = "&#8364;"
 181  toHtml (Command "ordinal" x)      = (toHtml x)++"<sup>"++"th"++"</sup>"
 182  -- FIXME: use "unicode vulgar fractions" here
 183  toHtml (Command "fraction" [n,d]) = "<sup>"++(toHtml n)++"</sup>"++"/"++"<sub>"++(toHtml d)++"</sub>"
 184  toHtml (Command "rfc" x)         = "<tt><a href=http://tools.ietf.org/html/rfc"++(toHtml x)++">RFC"++(toHtml x)++"</a></tt>"
 185
 186  -- FIXME: add div as well (for display-mode math)
 187  toHtml (Math m)                  = "<span class=math>" ++ (toHtml m) ++ "</span>"
 188  toHtml (Footnote x)              = error $ "footnotes not supported"
 189
 190  toHtml (GlyphText Euro)          = "&#8364;"
 191  toHtml (GlyphText CircleR)       = "&#162;"
 192  toHtml (GlyphText CircleC)       = "&#174;"
 193  toHtml (GlyphText TradeMark)     = "&#8482;"
 194  toHtml (GlyphText ServiceMark)   = "&#8482;"
 195  toHtml (GlyphText Emdash)        = "&mdash;"
 196  toHtml (GlyphText Ellipsis)      = "&#0133;"
 197  toHtml (GlyphText Cent)          = "&#189;"
 198  toHtml (GlyphText Daggar)        = "&#8224;"
 199  toHtml (GlyphText DoubleDaggar)  = "&#8225;"
 200  toHtml (GlyphText Clover)        = "&#8984;"
 201  toHtml (GlyphText Flat)          = "&#8918;"
 202  toHtml (GlyphText Natural)       = "&#8919;"
 203  toHtml (GlyphText Sharp)         = "&#8920;"
 204  toHtml (GlyphText CheckMark)     = "&#10003;"
 205  toHtml (GlyphText XMark)         = "&#10007;"
 206  toHtml (GlyphText LeftArrow)            = "&#;"  -- FIXME
 207  toHtml (GlyphText DoubleLeftArrow)      = "&#;"  -- FIXME
 208  toHtml (GlyphText DoubleRightArrow)     = "&#;"  -- FIXME
 209  toHtml (GlyphText DoubleLeftRightArrow) = "&#;"  -- FIXME
 210  toHtml (GlyphText LeftRightArrow)       = "&#;"  -- FIXME
 211  toHtml (GlyphText Degree)               = "&#;"  -- FIXME
 212
 213  toHtml (Command ('k':'e':'y':'s':'t':'r':'o':'k':'e':':':k) _) =
 214      "&#x"++(case k of
 215                "command" -> "2318"
 216                "shift" -> "21E7"
 217                "option" -> "2325"
 218                "control" -> "2303"
 219                "capslock" -> "21EA"
 220                "apple" -> "F8FF"
 221                )++";"
 222  toHtml (Command x y)             = error $ "unsupported command "++(show x)
 223
 224 instance ToHtml String where
 225   toHtml s = concatMap htmlEscapeChar s
 226    where
 227      htmlEscapeChar '<'  = "&lt;"
 228      htmlEscapeChar '>'  = "&gt;"
 229      htmlEscapeChar '&'  = "&amp;"
 230      htmlEscapeChar '\'' = "&apos;"
 231      htmlEscapeChar '\"' = "&quot;"
 232      htmlEscapeChar c    = [c]
 233
 234 pre x = "\n<div class=pre>"++ (pre' x) ++ "\n</div>\n"
 235  where
 236   pre' (' ':b)         = "&nbsp;"++(pre' b)
 237   pre' ('\n':b)        = "<br/>\n"++(pre' b)
 238   pre' (a:b)           = a:(pre' b)
 239   pre' []              = []
 240 \end{code}