implement the rest of the current basic tags
Getty Ritter
1 year, 10 months ago
| 1 | 1 | {-# LANGUAGE DeriveAnyClass #-} |
| 2 | 2 | {-# LANGUAGE OverloadedStrings #-} |
| 3 | 3 | |
| 4 |
module Main |
|
| 4 | module Main (main) where | |
| 5 | 5 | |
| 6 | 6 | import qualified Control.Exception.Base as Exn |
| 7 | 7 | import qualified Data.ByteString.Char8 as BS |
| 189 | 189 | |
| 190 | 190 | standardTags :: Text.Text -> [Text.Text] -> LuaM Text.Text |
| 191 | 191 | standardTags n ps = |
| 192 |
case |
|
| 192 | case n of | |
| 193 | 193 | -- \em to produce italics |
| 194 | ("em", [r]) -> pure ("<em>" <> r <> "</em>") | |
| 195 | ("em", _) -> throw (BuiltinArityMismatch 1 (length ps) n) | |
| 196 | -- \strong to produce bolding | |
| 197 | ("strong", [r]) -> pure ("<strong>" <> r <> "</strong>") | |
| 198 | ("strong", _) -> throw (BuiltinArityMismatch 1 (length ps) n) | |
| 199 | -- \li to produce list items | |
| 200 | ("li", [r]) -> pure ("<li>" <> r <> "</li>") | |
| 201 | ("li", _) -> throw (BuiltinArityMismatch 1 (length ps) n) | |
| 194 | "em" -> simpleTag n ps (\r -> "<em>" <> r <> "</em>") | |
| 195 | "strong" -> simpleTag n ps (\r -> "<strong>" <> r <> "</strong>") | |
| 196 | "h1" -> simpleTag n ps (\r -> "<h1>" <> r <> "</h1>") | |
| 197 | "h2" -> simpleTag n ps (\r -> "<h2>" <> r <> "</h2>") | |
| 198 | "p" -> simpleTag n ps (\r -> "<p class=\"para\">" <> r <> "</p>") | |
| 199 | "blockquote" -> simpleTag n ps (\r -> "<blockquote>" <> r <> "</blockquote>") | |
| 200 | "tt" -> simpleTag n ps (\r -> "<code>" <> r <> "</code>") | |
| 201 | "code" -> simpleTag n ps (\r -> "<pre><code>" <> r <> "</code></pre>") | |
| 202 | "center" -> simpleTag n ps (\r -> "<div class=\"center\">" <> r <> "</div>") | |
| 203 | -- some of the variadic ones | |
| 204 | "ul" -> | |
| 205 | pure ("<ul>" <> mconcat ["<li>" <> p <> "</li>" | p <- ps] <> "</ul>") | |
| 206 | "ol" -> | |
| 207 | pure ("<ol>" <> mconcat ["<li>" <> p <> "</li>" | p <- ps] <> "</ol>") | |
| 208 | "br" -> | |
| 209 | pure "<br/>" | |
| 210 | "comment" -> pure "" | |
| 211 | "link" -> case ps of | |
| 212 | [address, text] -> | |
| 213 | pure ("<a href=\"" <> address <> "\">" <> text <> "</a>") | |
| 214 | _ -> throw (BuiltinArityMismatch 2 (length ps) n) | |
| 215 | "img" -> case ps of | |
| 216 | [address] -> | |
| 217 | pure ("<img src=\"" <> address <> "\">") | |
| 218 | [address, altText] -> | |
| 219 | pure ("<img src=\"" <> address <> "\" alt=\"" <> altText <> "\">") | |
| 220 | _ -> throw (BuiltinArityMismatch 1 (length ps) n) | |
| 202 | 221 | _ -> throw (NoSuchTag n) |
| 222 | ||
| 223 | simpleTag :: Text.Text -> [Text.Text] -> (Text.Text -> Text.Text) -> LuaM Text.Text | |
| 224 | simpleTag _ [item] result = pure (result item) | |
| 225 | simpleTag name items _ = throw (BuiltinArityMismatch 1 (length items) name) | |
| 203 | 226 | |
| 204 | 227 | handleDoc :: TeLML.Document -> LuaM Text.Text |
| 205 | 228 | handleDoc = fmap mconcat . sequence . map handleFrag |