\begin{code} -- Copyright 2008 the Contributors, as shown in the revision logs. -- Licensed under the Apache Public Source License 2.0 ("the License"). -- You may not use this file except in compliance with the License. module Html where import Edu_Berkeley_Sbp_Haskell_SBP import FromTree import Doc import List(isSuffixOf,isPrefixOf) -- FIXME: use pretty-printing when asked to for better display class ToHtml a where toHtml :: a -> String instance ToHtml a => ToHtml [a] where toHtml x = concatMap toHtml x style = "\n\n" instance ToHtml Doc where toHtml (Doc h secs) = "\n"++ "\n\n"++ "\n"++ "\n"++ style++ --FIXME: title tag "\n"++ "\n"++ -- tell jsmath we will escape stuff manually -- FIXME: only put this in if math appears on the page "\n"++ "\n"++ "\n"++ "\n"++ "
\n"++ (toHtml secs) ++ "

\n"++ ""++ "\n"++ "
\n"++ "" quoteIconBase64 = "data:image/png;base64," ++"iVBORw0KGgoAAAANSUhEUgAAABAAAAAVCAYAAABPPm7SAAAABmJLR0QA/wD/AP+gvaeTAAAA" ++"CXBIWXMAAAsTAAALEwEAmpwYAAAAB3RJTUUH1wQPAx0rP5obpAAAAWJJREFUOMvdlKFvg0AU" ++"xr8tVZ1cbU+04lUuwc2WypMX9AxiomoJ/RNYqmaaYKpb5kBys1UkWBCdKLqVs8zwFnrQmYol" ++"+xLC8X55H/e+wAENhWGoPM/zT6eThQ4lSWJf5EEQuAAqAJXv+95vXCkVtpwZuq4bmM1pmlrM" ++"LctKWzuwbTsBUNX3lph3Njfd6/WZ9vv9iHkYhsrkPa21zQ9aa9v3fRsAFovFK9cMPgIApdT7" ++"eDz+RB1Y1XEBwEVe54ZbXKm/N7haNwCQ5zmtVqtnE0op49lspgFgPp+/dfF/EGIPAAaDgZBS" ++"xgBwPB7vd7vdIwD0+/2v5ry8juNYmgY/P1GWZQ9sQER3XOcwD4fDkA2IqGiNwN8+ERVNY/Pt" ++"RFQIIcozg+Vy+VKW5dDcMmuz2ThFURAATKfTj7MQ1+v1Ezc7jrMVQpTmocOjOY6znUwmRSvR" ++"KIpknud0KfEoimSWZQ/N2jfhtb1AvGklDQAAAABJRU5ErkJggg==" warnIconBase64 = "data:image/png;base64," ++"iVBORw0KGgoAAAANSUhEUgAAABQAAAAREAYAAACN1FD9AAAABmJLR0QA/wD/AP+gvaeTAAAA" ++"CXBIWXMAAABIAAAASABGyWs+AAAACXZwQWcAAAAUAAAAEQDeTN6UAAAD/ElEQVRIx8WUbUyV" ++"ZRjHf+chxDi8yZcDa0mKh/wSuNE5eNYHZBiRwoespayEkdgx22hmjB1glTlenDYlMccAX1cb" ++"CDFlg+aQ1JGEazGWpixdbbweDucctPF2PNxXX3pw00gL09+X59m1+77+v+d+nueCBRJ+ECAs" ++"78dnAPp2nLEDtMdpPwMYZhfaf8GU1gLsixwdBRDRr7lRAHmxT0zs+UKAuKmhXgDfGleAYZVh" ++"lXynC/Z1AYyeX+IFiLjw+MwWAxDQuBqgNVsX+iNta/nWcnV0vD+9Ir1CndDre68AfDH42PzW" ++"2QDW79UFxkxh6WHp8o5a5lznXCfJ/nPX867nSYArO7AssEyOjOwE8GfGZwC84Pu3edrDLgzK" ++"AFj06q7DAPt/1evBK4szizMlpXy4tqO2g/MHa9sm2ibwP23M78zvFE0rBAg4U24DqFpieAqA" ++"6kd+cjuiAAqu6Sfn/n55/fJ6CZOc6YHpATmkNWgNWoOIZtSMmlFE1d9ae2utvDt21ZRiSpHV" ++"+r43LwFkBT4ysehigKgDvxcC3P5QD5qxNtU11anj8hfhg+GD4YMixipjlbFK5pjyHok8Enn3" ++"m7yyG2DAEdIFYLy9YMHDLoBjK/WA8fhkb7JXtcqMnJbT4tJFYlpiWmJaRKJio2KjYu8KSp9K" ++"UAly2ZtpSbWkql/0PrsuAJR3/2cx65cA1qujRgBV6HpWy9fy5dydOz2JPYlqQO4hwZ/gT/CL" ++"mB1mh9kh93Enq2tP1x7V4wo0pBnS5KehVwBmPjA7AcxtDy2mBQIYPmk/B/CDb26MxGw5teWU" ++"+krmIdWaak21iiR2JHYkdsi83G7KtmRb1HG9b+PHAK2lJAEQ9EDBt88C5BybGyOLQgtCC8Su" ++"gkesI1axzRd8Mvdk7slckeoN1RuqN8wvODsyVDNUIxaXP0SFKHlfz8l4GSDTfd+B6Tdh5QCh" ++"hUUvAlR8o9eDI4qSipLkJcOEqdvUzaX5HmzSNGmaNMFN+037TTvgxInzb96QKTovOo/LRmuJ" ++"r8QnFr3+2esAB/IX9wAEjd+3cfc+gD2euTFSv2zzss0SIdnTG6c3SqU8AFulrdJWKRJSElIS" ++"UiLia/Y1+5r/YcNHM9tntku1e2KFZ4VHAvXcwnyAksY5MfNvAOYdQ+8BzHytL5warDtRd2I2" ++"QjWNh46HqjR11LvGu0aVqUOei56LYlD7PRWeCmlWpe4p95R87h66Yb9hV+7+o71BvUHKoWyj" ++"jlGHSlbPOTc5N6kkFTqybWSbeksxfHb4rGqd9Q3nDOdI5lRHTXtNu6rWc/vfAJjoXHoNYOl6" ++"Q70CaFEpYwAZhof+m/5nvv0UoDFLW/UagCXuSQvdSzwAiTv/BGXg1AxNKyCeAAAAAElFTkSu" ++"QmCC" printIconBase64 = "data:image/png;base64," ++"iVBORw0KGgoAAAANSUhEUgAAAA8AAAAOCAMAAADHVLbdAAAALHRFWHRDcmVhdGlvbiBUaW1l" ++"AEZyaSAxOSBTZXAgMjAwMyAxODozOTozMiAtMDAwME2jAt8AAAAHdElNRQfTCRMRKABXeznM" ++"AAAACXBIWXMAAAsSAAALEgHS3X78AAAABGdBTUEAALGPC/xhBQAAACRQTFRF////AAAA7+/v" ++"3t7ezs7OtbW1ra2tlJSUnJycEBAQKSkphISEbGtEogAAAAF0Uk5TAEDm2GYAAABLSURBVHja" ++"nY1BEsAgCAMDKm31//81qB3l6h4Y4mYQQNvAmXNv7W/gytcTRj6pppQHNWoW6JWS13Ix86yr" ++"O7MEPkDWuWLPK/7hoYEOxksDsk8eppEAAAAASUVORK5CYII=" emailIconBase64 = "data:image/png;base64," ++"iVBORw0KGgoAAAANSUhEUgAAABUAAAAOCAMAAAD32Kf8AAAALHRFWHRDcmVhdGlvbiBUaW1l" ++"AEZyaSAxOSBTZXAgMjAwMyAxODo0MjowOSAtMDAwMBDwv7IAAAAHdElNRQfTCRMRKhqYL6I0" ++"AAAACXBIWXMAAAsSAAALEgHS3X78AAAABGdBTUEAALGPC/xhBQAAADBQTFRF////AAAAhISE" ++"9/fv9/f3////CAgI7+/v1tbOxsa9tbWtpaWclJSMlJSUe3t7a2trxDv8WgAAAAF0Uk5TAEDm" ++"2GYAAABiSURBVHjabc9JEoAgDETRpNOKs/e/rSEYF8jfhHpQFAi6JHpHBg5VOdIj+KeXkgO9" ++"tUj/Bldo3WdRnktt3fbjgoWKK5EKsunkyryCn86Oxsj/UZqKEkFmNF+mvieFdSK16wFr7QK5" ++"tASqkwAAAABJRU5ErkJggg==" pdfIconBase64 = "data:image/png;base64," ++"iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAMAAAAoLQ9TAAAAK3RFWHRDcmVhdGlvbiBUaW1l" ++"AFRodSA2IE5vdiAyMDAzIDE1OjMwOjAwIC0wMDAwSwt8PwAAAAd0SU1FB9MLBg8fD1x8/t4A" ++"AAAJcEhZcwAACxIAAAsSAdLdfvwAAAAEZ0FNQQAAsY8L/GEFAAAAQlBMVEX///9zc3Nra2uE" ++"hITGxsaUlJScnJx7e3uMjIz////39/fv7+/n5+fe3t69vb1jY2OlpaXW1ta1tbVaWlqtra3O" ++"zs5w48BYAAAAAXRSTlMAQObYZgAAAIdJREFUeNpNz1ESBBEMBNCRwSCJMOT+V10WW9vKz6uO" ++"iusa0R137ShxjImwHsnSMCbEX6dPiIje+SUKC6hav8CbAQlZD/RmJ1Tdz6oTwETMfAByK0hT" ++"1kgH7E1phFfjdvS2JlJpN8RAyEHMhgJgaexJTBPyA1JiGoD0BXgg2H8wcFs3/jDvPB+sOwir" ++"+o6iKQAAAABJRU5ErkJggg==" instance ToHtml Section where toHtml (Section level header paragraphs) = "\n\n"++ (toHtml header)++ "\n\n"++ (toHtml paragraphs) stag t body = "\n<"++t++">\n"++body++"\n\n" tag t body = "<"++t++">"++body++"" instance ToHtml Paragraph where toHtml (Blockquote t) = "\n\n" ++"\n" ++"
\n" ++(toHtml t) ++"
\n" toHtml HR = stag "hr" [] toHtml (OL t) = stag "ol" $ concatMap (\x -> stag "li" $ concatMap toHtml x) t toHtml (UL t) = stag "ul" $ concatMap (\x -> stag "li" $ concatMap toHtml x) t toHtml (P t) = stag "p" $ toHtml t link ref body = ""++icon++body++"" where icon = if ".pdf" `isSuffixOf` ref then " " else if "mailto:" `isPrefixOf` ref then " " else "" img = "style='vertical-align: text-bottom;' border=0 " -- margin-bottom: -2px; padding-bottom: 2px; border-bottom: 1px blue solid; instance ToHtml Text where toHtml WS = " " toHtml (Chars s) = toHtml s -- directional quotes: see http://www.dwheeler.com/essays/quotes-in-html.html toHtml (Quotes x) = "“"++(toHtml x)++"”" toHtml (Verbatim x) = pre x toHtml (Link t ref) = link (show ref) (toHtml t) toHtml (Command "comment" y) = "" toHtml (Command "url" y) = ""++(link (toHtml y) (toHtml y))++"" toHtml (Command "WiX" y) = "WIX" toHtml (Command "TeX" y) = "TEX" -- u'1/2' : u'\u00BD', -- u'1/4' : u'\u00BC', -- u'3/4' : u'\u00BE', -- u'1/3' : u'\u2153', -- u'2/3' : u'\u2154', -- u'1/5' : u'\u2155', -- u'2/5' : u'\u2156', -- u'3/5' : u'\u2157', -- u'4/5' : u'\u2158', -- u'1/6' : u'\u2159', -- u'5/6' : u'\u215A', -- u'1/8' : u'\u215B', -- u'3/8' : u'\u215C', -- u'5/8' : u'\u215D', -- u'7/8' : u'\u215E', toHtml (Styled Underline x) = tag "u" $ toHtml x toHtml (Styled TT x) = tag "tt" $ toHtml x toHtml (Styled Italic x) = tag "i" $ toHtml x toHtml (Styled Strikethrough x) = tag "strike" $ toHtml x toHtml (Styled Superscript x) = tag "sup" $ toHtml x toHtml (Styled Subscript x) = tag "sub" $ toHtml x toHtml (Styled Bold x) = tag "b" $ toHtml x toHtml (Styled Highlight x) = ""++(toHtml x)++"" toHtml (Keyword x) = tag "tt" $ toHtml x toHtml (SubPar x) = stag "p" $ concatMap toHtml x toHtml (Command "red" y) = ""++(toHtml y)++"" toHtml (Command "orange" y) = ""++(toHtml y)++"" toHtml (Command "green" y) = ""++(toHtml y)++"" toHtml (Command "sc" y) = ""++(toHtml y)++"" toHtml (Command "image" y) = "" toHtml (Command "imagec" y) = "
" toHtml (Command "image2" y) = "" toHtml (Command "image3" y) = "" toHtml (Command "image4" y) = "
" toHtml (Command "warn" y) = "\n
\n\n" ++"\n" ++"
\n" ++(toHtml y) ++"
\n" toHtml (Command "announce" y) = "\n
\n\n" ++"\n" ++"
\n" ++(toHtml y) ++"
\n" toHtml (Command "br" _) = "\n
\n" toHtml (Command "cent" _) = "½" toHtml (Command "euro" _) = "€" -- gross hack toHtml (Command "ordinal" x) | (last (toHtml x) == '1') = (toHtml x)++""++"st"++"" | (last (toHtml x) == '2') = (toHtml x)++""++"nd"++"" | (last (toHtml x) == '3') = (toHtml x)++""++"rd"++"" | otherwise = (toHtml x)++""++"th"++"" -- FIXME: use "unicode vulgar fractions" here toHtml (Command "fraction" [n,d]) = ""++(toHtml n)++""++"/"++""++(toHtml d)++"" toHtml (Command "rfc" x) = "RFC"++(toHtml x)++"" -- FIXME: add div as well (for display-mode math) toHtml (Math m) = "" ++ (toHtml m) ++ "" toHtml (Footnote x) = error $ "footnotes not supported" toHtml (GlyphText Euro) = "€" toHtml (GlyphText CircleR) = "¢" toHtml (GlyphText CircleC) = "®" toHtml (GlyphText TradeMark) = "™" toHtml (GlyphText ServiceMark) = "™" toHtml (GlyphText Emdash) = "—" toHtml (GlyphText Ellipsis) = "…" toHtml (GlyphText Cent) = "½" toHtml (GlyphText Daggar) = "†" toHtml (GlyphText DoubleDaggar) = "‡" toHtml (GlyphText Clover) = "⌘" toHtml (GlyphText Flat) = "⋖" toHtml (GlyphText Natural) = "⋗" toHtml (GlyphText Sharp) = "⋘" toHtml (GlyphText CheckMark) = "✓" toHtml (GlyphText XMark) = "✗" toHtml (GlyphText LeftArrow) = "&#;" -- FIXME toHtml (GlyphText DoubleLeftArrow) = "&#;" -- FIXME toHtml (GlyphText DoubleRightArrow) = "&#;" -- FIXME toHtml (GlyphText DoubleLeftRightArrow) = "&#;" -- FIXME toHtml (GlyphText LeftRightArrow) = "&#;" -- FIXME toHtml (GlyphText Degree) = "&#;" -- FIXME toHtml (Command ('k':'e':'y':'s':'t':'r':'o':'k':'e':':':k) _) = "&#x"++(case k of "command" -> "2318" "shift" -> "21E7" "option" -> "2325" "control" -> "2303" "capslock" -> "21EA" "apple" -> "F8FF" )++";" toHtml (Command x y) = error $ "unsupported command "++(show x) instance ToHtml String where toHtml s = concatMap htmlEscapeChar s htmlEscapeChar '<' = "<" htmlEscapeChar '>' = ">" htmlEscapeChar '&' = "&" htmlEscapeChar '\'' = "'" htmlEscapeChar '\"' = """ htmlEscapeChar c = [c] pre x = "\n
"++ (pre' x) ++ "\n
\n" where pre' (' ':b) = " "++(pre' b) pre' ('\n':b) = "
\n"++(pre' b) pre' (a:b) = (htmlEscapeChar a)++(pre' b) pre' [] = [] \end{code}