| 1 |
module Text.Ptolemy.HTML.Writer (writeHtml, writeHtmlStrict) where
|
| 2 |
|
| 3 |
import Data.Monoid ((<>))
|
| 4 |
import qualified Data.Text as TS
|
| 5 |
import Data.Text.Lazy (Text, toStrict)
|
| 6 |
import Data.Text.Lazy.Builder (Builder)
|
| 7 |
import qualified Data.Text.Lazy.Builder as B
|
| 8 |
import Data.Vector (Vector)
|
| 9 |
import qualified Data.Vector as V
|
| 10 |
import Text.Ptolemy.Core
|
| 11 |
|
| 12 |
-- | Render a Ptolemy @Document@ as HTML represented as lazy @Text@.
|
| 13 |
writeHtml :: Document -> Text
|
| 14 |
writeHtml = B.toLazyText . build
|
| 15 |
|
| 16 |
-- | Render a Ptolemy @Document@ as HTML represented as strict @Text@.
|
| 17 |
writeHtmlStrict :: Document -> TS.Text
|
| 18 |
writeHtmlStrict = toStrict . writeHtml
|
| 19 |
|
| 20 |
-- These will be our helper functions for building tags
|
| 21 |
tag :: Text -> Builder -> Builder
|
| 22 |
tag t bs = "<" <> build t <> ">" <> bs <> "</" <> build t <> ">"
|
| 23 |
|
| 24 |
tagAttrs :: Text -> [(TS.Text, TS.Text)] -> Builder -> Builder
|
| 25 |
tagAttrs t [] bs = tag t bs
|
| 26 |
tagAttrs t as bs =
|
| 27 |
"<" <> build t <> attrs as <> ">" <> bs <> "</" <> build t <> ">"
|
| 28 |
where attrs [] = mempty
|
| 29 |
attrs ((k,v):xs) =
|
| 30 |
" " <> build k <> "=\"" <> build v <> "\"" <> attrs xs
|
| 31 |
|
| 32 |
-- Right now, this just makes the code below a lot smaller: we
|
| 33 |
-- abstract out the notion of 'building' a thing, so we can
|
| 34 |
-- more or less indiscriminately apply @build@ to vectors or
|
| 35 |
-- maps or what-have-you.
|
| 36 |
class Build t where
|
| 37 |
build :: t -> Builder
|
| 38 |
|
| 39 |
-- And to that end, we define a handful of utility
|
| 40 |
-- implementations of things:
|
| 41 |
instance Build t => Build (Vector t) where
|
| 42 |
build = foldMap build
|
| 43 |
|
| 44 |
instance Build Text where
|
| 45 |
build = B.fromLazyText
|
| 46 |
|
| 47 |
instance Build TS.Text where
|
| 48 |
build = B.fromText
|
| 49 |
|
| 50 |
instance Build Block where
|
| 51 |
build (Plain cs) = build cs
|
| 52 |
build (Para cs) = tag "p" $ build cs
|
| 53 |
build (CodeBlock _ ts) = tag "pre" $ tag "code" $ build ts
|
| 54 |
build (RawBlock _ _) = undefined
|
| 55 |
build (BlockQuote bs) = tag "blockquote" $ build bs
|
| 56 |
build (OrderedList la ds) =
|
| 57 |
tagAttrs "ol" (orderedListAttrs la) $ foldMap (tag "li" . build) ds
|
| 58 |
build (BulletList ds) =
|
| 59 |
tag "ul" $ foldMap (tag "li" . build) ds
|
| 60 |
build (DefinitionList ds) =
|
| 61 |
tag "dl" $ foldMap build ds
|
| 62 |
build (Header n _ is) =
|
| 63 |
case n of
|
| 64 |
1 -> tag "h1" $ build is
|
| 65 |
2 -> tag "h2" $ build is
|
| 66 |
3 -> tag "h3" $ build is
|
| 67 |
4 -> tag "h4" $ build is
|
| 68 |
_ -> undefined -- XXX
|
| 69 |
build HorizontalRule = "<hr/>"
|
| 70 |
build (Div as ds) = tagAttrs "div" (mkAttrs as) $ build ds
|
| 71 |
build Null = mempty
|
| 72 |
|
| 73 |
whitesep :: Foldable f => f TS.Text -> TS.Text
|
| 74 |
whitesep = foldl sep ""
|
| 75 |
where sep x y = x <> " " <> y
|
| 76 |
|
| 77 |
mkAttrs :: Attr -> [(TS.Text, TS.Text)]
|
| 78 |
mkAttrs Attr { attrIdentifier = ai
|
| 79 |
, attrClasses = cs
|
| 80 |
, attrProps = _ -- XXX
|
| 81 |
} = htmlId <> htmlCs <> htmlPs
|
| 82 |
where htmlId | ai /= "" = [("id", ai)]
|
| 83 |
| otherwise = []
|
| 84 |
htmlCs | V.null cs = []
|
| 85 |
| otherwise = [("class", whitesep cs)]
|
| 86 |
htmlPs = []
|
| 87 |
|
| 88 |
orderedListAttrs :: ListAttributes -> [(TS.Text, TS.Text)]
|
| 89 |
orderedListAttrs _ = [("style", "list-style-type: decimal")]
|
| 90 |
|
| 91 |
instance Build Definition where
|
| 92 |
build Definition
|
| 93 |
{ dfTerm = term
|
| 94 |
, dfDefinition = defn
|
| 95 |
} = tag "dt" (build term) <> tag "dd" (build defn)
|
| 96 |
|
| 97 |
instance Build Inline where
|
| 98 |
build (Str t) = build t
|
| 99 |
build (Emph is) = tag "em" $ build is
|
| 100 |
build (Strong is) = tag "strong" $ build is
|
| 101 |
build (Strikeout is) = tag "del" $ build is
|
| 102 |
build (Superscript is) = tag "span" $ build is -- XXX
|
| 103 |
build (Subscript is) = tag "span" $ build is -- XXX
|
| 104 |
build (SmallCaps is) = tag "span" $ build is -- XXX
|
| 105 |
build Space = " "
|
| 106 |
build (Code _ t) = tag "code" $ build t
|
| 107 |
build SoftBreak = mempty
|
| 108 |
build LineBreak = "<br/>"
|