Began implementation of HTML writer

ptolemy-writer-html/Text/Ptolemy/HTML/Writer.hs

@@ -0,0 +1,108 @@
+module Text.Ptolemy.HTML.Writer (writeHtml, writeHtmlStrict) where
+
+import           Data.Monoid ((<>))
+import qualified Data.Text as TS
+import           Data.Text.Lazy (Text, toStrict)
+import           Data.Text.Lazy.Builder (Builder)
+import qualified Data.Text.Lazy.Builder as B
+import           Data.Vector (Vector)
+import qualified Data.Vector as V
+import           Text.Ptolemy.Core
+
+-- | Render a Ptolemy @Document@ as HTML represented as lazy @Text@.
+writeHtml :: Document -> Text
+writeHtml = B.toLazyText . build
+
+-- | Render a Ptolemy @Document@ as HTML represented as strict @Text@.
+writeHtmlStrict :: Document -> TS.Text
+writeHtmlStrict = toStrict . writeHtml
+
+-- These will be our helper functions for building tags
+tag :: Text -> Builder -> Builder
+tag t bs = "<" <> build t <> ">" <> bs <> "</" <> build t <> ">"
+
+tagAttrs :: Text -> [(TS.Text, TS.Text)] -> Builder -> Builder
+tagAttrs t [] bs = tag t bs
+tagAttrs t as bs =
+  "<" <> build t <> attrs as <> ">" <> bs <> "</" <> build t <> ">"
+  where attrs [] = mempty
+        attrs ((k,v):xs) =
+          " " <> build k <> "=\"" <> build v <> "\"" <> attrs xs
+
+-- Right now, this just makes the code below a lot smaller: we
+-- abstract out the notion of 'building' a thing, so we can
+-- more or less indiscriminately apply @build@ to vectors or
+-- maps or what-have-you.
+class Build t where
+  build :: t -> Builder
+
+-- And to that end, we define a handful of utility
+-- implementations of things:
+instance Build t => Build (Vector t) where
+  build = foldMap build
+
+instance Build Text where
+  build = B.fromLazyText
+
+instance Build TS.Text where
+  build = B.fromText
+
+instance Build Block where
+  build (Plain cs) = build cs
+  build (Para cs) = tag "p" $ build cs
+  build (CodeBlock _ ts) = tag "pre" $ tag "code" $ build ts
+  build (RawBlock _ _) = undefined
+  build (BlockQuote bs) = tag "blockquote" $ build bs
+  build (OrderedList la ds) =
+    tagAttrs "ol" (orderedListAttrs la) $ foldMap (tag "li" . build) ds
+  build (BulletList ds) =
+    tag "ul" $ foldMap (tag "li" . build) ds
+  build (DefinitionList ds) =
+    tag "dl" $ foldMap build ds
+  build (Header n _ is) =
+    case n of
+      1 -> tag "h1" $ build is
+      2 -> tag "h2" $ build is
+      3 -> tag "h3" $ build is
+      4 -> tag "h4" $ build is
+      _ -> undefined -- XXX
+  build HorizontalRule = "<hr/>"
+  build (Div as ds) = tagAttrs "div" (mkAttrs as) $ build ds
+  build Null = mempty
+
+whitesep :: Foldable f => f TS.Text -> TS.Text
+whitesep = foldl sep ""
+  where sep x y = x <> " " <> y
+
+mkAttrs :: Attr -> [(TS.Text, TS.Text)]
+mkAttrs Attr { attrIdentifier = ai
+             , attrClasses    = cs
+             , attrProps      = _ -- XXX
+             } = htmlId <> htmlCs <> htmlPs
+  where htmlId | ai /= ""  = [("id", ai)]
+               | otherwise = []
+        htmlCs | V.null cs = []
+               | otherwise = [("class", whitesep cs)]
+        htmlPs = []
+
+orderedListAttrs :: ListAttributes -> [(TS.Text, TS.Text)]
+orderedListAttrs _ = [("style", "list-style-type: decimal")]
+
+instance Build Definition where
+  build Definition
+    { dfTerm       = term
+    , dfDefinition = defn
+    } = tag "dt" (build term) <> tag "dd" (build defn)
+
+instance Build Inline where
+  build (Str t) = build t
+  build (Emph is) = tag "em" $ build is
+  build (Strong is) = tag "strong" $ build is
+  build (Strikeout is) = tag "del" $ build is
+  build (Superscript is) = tag "span" $ build is -- XXX
+  build (Subscript is) = tag "span" $ build is -- XXX
+  build (SmallCaps is) = tag "span" $ build is -- XXX
+  build Space = " "
+  build (Code _ t) = tag "code" $ build t
+  build SoftBreak = mempty
+  build LineBreak = "<br/>"

ptolemy-writer-html/ptolemy-writer-html.cabal

@@ -12,9 +12,12 @@ build-type:       Simple
 cabal-version:    >= 1.2
 
 library
+  exposed-modules:     Text.Ptolemy.HTML.Writer
   ghc-options:         -Wall
-  build-depends:       base >=4.7 && <4.9
+  build-depends:       base >=4.7 && <4.9,
+                       ptolemy-core,
+                       text,
+                       vector
   default-language:    Haskell2010
   default-extensions:  OverloadedStrings,
                        ScopedTypeVariables