Markdown writer: Support yaml title block.

2 files changed, 37 insertions, 12 deletions

diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs
index d37146346..d8ac99685 100644
--- a/src/Text/Pandoc/Writers/Markdown.hs
+++ b/src/Text/Pandoc/Writers/Markdown.hs
@@ -46,6 +46,10 @@ import Text.Pandoc.Readers.TeXMath (readTeXMath)
 import Text.HTML.TagSoup (renderTags, parseTags, isTagText, Tag(..))
 import Network.URI (isAbsoluteURI)
 import Data.Default
+import Data.Yaml (Value(Object,String,Array,Bool,Number))
+import qualified Data.HashMap.Strict as H
+import qualified Data.Vector as V
+import qualified Data.Text as T
 
 type Notes = [[Block]]
 type Refs = [([Inline], Target)]
@@ -109,16 +113,42 @@ plainTitleBlock tit auths dat =
   (hcat (intersperse (text "; ") auths)) <> cr <>
   dat <> cr
 
+yamlTitleBlock :: Value -> Doc
+yamlTitleBlock v = "---" $$ (jsonToYaml v) $$ "..."
+
+jsonToYaml :: Value -> Doc
+jsonToYaml (Object hashmap) =
+  vcat (map (\(k,v) ->
+    text (T.unpack k) <> ":" <> space <> jsonToYaml v) $ H.toList hashmap)
+jsonToYaml (Array vec) =
+  cr <> vcat (map (\v -> hang 2 "- " (jsonToYaml v)) $ V.toList vec)
+jsonToYaml (String s)
+  | "\n" `T.isInfixOf` s = hang 2 ("|" <> cr) $ text $ T.unpack s
+  | otherwise            = text $ "'" ++ substitute "'" "''" (T.unpack s) ++ "'"
+jsonToYaml (Bool b) = text $ show b
+jsonToYaml (Number n) = text $ show n
+jsonToYaml _ = empty
+
 -- | Return markdown representation of document.
 pandocToMarkdown :: WriterOptions -> Pandoc -> State WriterState String
 pandocToMarkdown opts (Pandoc meta blocks) = do
   title' <- inlineListToMarkdown opts $ docTitle meta
   authors' <- mapM (inlineListToMarkdown opts) $ docAuthors meta
   date' <- inlineListToMarkdown opts $ docDate meta
+  let colwidth = if writerWrapText opts
+                    then Just $ writerColumns opts
+                    else Nothing
+  metadata <- metaToJSON
+              (fmap (render colwidth) . blockListToMarkdown opts)
+              (fmap (render colwidth) . inlineListToMarkdown opts)
+              (writerVariables opts)
+              meta
   isPlain <- gets stPlain
   let titleblock = case True of
                         _ | isPlain ->
                               plainTitleBlock title' authors' date'
+                          | isEnabled Ext_yaml_title_block opts ->
+                              yamlTitleBlock metadata
                           | isEnabled Ext_pandoc_title_block opts ->
                               pandocTitleBlock title' authors' date'
                           | isEnabled Ext_mmd_title_block opts ->
@@ -128,14 +158,6 @@ pandocToMarkdown opts (Pandoc meta blocks) = do
   let toc = if writerTableOfContents opts
                then tableOfContents opts headerBlocks
                else empty
-  let colwidth = if writerWrapText opts
-                    then Just $ writerColumns opts
-                    else Nothing
-  metadata <- metaToJSON
-              (fmap (render colwidth) . blockListToMarkdown opts)
-              (fmap (render colwidth) . inlineListToMarkdown opts)
-              (writerVariables opts)
-              meta
   body <- blockListToMarkdown opts blocks
   st <- get
   notes' <- notesToMarkdown opts (reverse $ stNotes st)
diff --git a/tests/writer.markdown b/tests/writer.markdown
index d9cc076f5..e8aca9954 100644
--- a/tests/writer.markdown
+++ b/tests/writer.markdown
@@ -1,7 +1,10 @@
-% Pandoc Test Suite
-% John MacFarlane
-  Anonymous
-% July 17, 2006
+---
+title: 'Pandoc Test Suite'
+author:
+- 'John MacFarlane'
+- 'Anonymous'
+date: 'July 17, 2006'
+...
 
 This is a set of tests for pandoc. Most of them are adapted from John Gruber’s
 markdown test suite.