Updated tag set to correspond more closely to the one used in van-de-graaf
Getty Ritter
7 years ago
| 1 | 1 | {-# LANGUAGE LambdaCase #-} |
| 2 | {-# LANGUAGE OverloadedStrings #-} | |
| 2 | 3 | |
| 3 | 4 | module Data.TeLML.Markup where |
| 4 | 5 | |
| 6 | 7 | import Data.TeLML |
| 7 | 8 | import Text.Blaze.Html |
| 8 | 9 | import Text.Blaze.Html5 hiding (map, head, html) |
| 9 |
import Text.Blaze.Html5.Attributes hiding (name |
|
| 10 | import Text.Blaze.Html5.Attributes hiding (name, span) | |
| 11 | ||
| 12 | import Prelude hiding (div, span) | |
| 10 | 13 | |
| 11 | 14 | -- | Render a TeLML document with an extra set of possible tags. |
| 12 | 15 | renderWith :: [(String, Renderer)] -> Document -> Either String Html |
| 46 | 49 | -- The built-in set of tags (subject to change) |
| 47 | 50 | basicTags :: [(String, Renderer)] |
| 48 | 51 | basicTags = |
| 49 | [ ("em" | |
| 50 | , \case (f,[rs]) -> fmap (em . sequence_) (mapM f rs) | |
| 51 | _ -> Left "wrong arity for em/1" | |
| 52 | ) | |
| 53 | , ("strong" | |
| 54 | , \case (f,[rs]) -> fmap (strong . sequence_) (mapM f rs) | |
| 55 | _ -> Left "wrong arity for strong/1" | |
| 56 | ) | |
| 57 | , ("code" | |
| 58 | , \case (f,[rs]) -> fmap (code . sequence_) (mapM f rs) | |
| 59 | _ -> Left "wrong arity for code/1" | |
| 60 | ) | |
| 52 | [ simpleTag "em" em | |
| 53 | , simpleTag "strong" strong | |
| 54 | , simpleTag "li" li | |
| 55 | , simpleTag "h1" h1 | |
| 56 | , simpleTag "h2" h2 | |
| 57 | , simpleTag "p" (\ rs -> span ! class_ "para" $ rs) | |
| 58 | , simpleTag "blockquote" blockquote | |
| 59 | , simpleTag "tt" code | |
| 60 | , simpleTag "code" (pre . code) | |
| 61 | , simpleTag "ttcom" (\ rs -> span ! class_ "comment" $ rs) | |
| 62 | , simpleTag "ttkw" (\ rs -> span ! class_ "keyword" $ rs) | |
| 63 | , simpleTag "ttcn" (\ rs -> span ! class_ "constr" $ rs) | |
| 64 | , simpleTag "ttstr" (\ rs -> span ! class_ "string" $ rs) | |
| 65 | , listTag "ul" ul | |
| 66 | , listTag "ol" ol | |
| 67 | , listTag "center" (\ rs -> div ! class_ "center" $ rs) | |
| 68 | , ("br", \_ -> return br) | |
| 69 | , ("comment", \_ -> return "") | |
| 61 | 70 | , ("link" |
| 62 | 71 | , \case (f,[[Text l],r]) -> let go h = a ! href (stringValue l) $ h |
| 63 | 72 | in fmap (go . sequence_) (mapM f r) |
| 64 | 73 | (_,[_,_]) -> Left "link target should be string" |
| 65 | 74 | _ -> Left "wrong arity for link/1" |
| 66 | 75 | ) |
| 76 | , ("img" | |
| 77 | , \case (_, [[Text l]]) -> return (img ! src (stringValue l)) | |
| 78 | (_,[_]) -> Left "image target should be string" | |
| 79 | _ -> Left "wrong arity for img/1" | |
| 80 | ) | |
| 67 | 81 | ] |
| 82 | where simpleTag :: String -> (Html -> Html) -> (String, Renderer) | |
| 83 | simpleTag name tag = | |
| 84 | ( name | |
| 85 | , \case (f,[rs]) -> fmap (tag . sequence_) (mapM f rs) | |
| 86 | _ -> Left ("wrong arity for " ++ name ++ "/1") | |
| 87 | ) | |
| 88 | listTag name tag = | |
| 89 | ( name | |
| 90 | , \case (f,rs) -> fmap (tag . sequence_) (mapM f (concat rs)) | |
| 91 | ) | |
| 68 | 92 | |
| 69 | 93 | -- render a single paragraph |
| 70 | 94 | renderPara :: [(String, Renderer)] -> Document -> Either String Html |