Changes to ConTeXt writer:

+ PrettyPrint module now used for output.
+ Text wrapping now provided, using wrapTeXIfNeeded.
+ Better treatment of footnotes:  footnotes are always on lines by themselves.
+ Use \subject, \subsubject, ... or \section, \subsection, ... for headings,
  depending on whether --number-sections option is selected.


git-svn-id: https://pandoc.googlecode.com/svn/trunk@1072 788f1e2b-df1e-0410-8736-df70ead52e1b

1 files changed, 135 insertions, 121 deletions

diff --git a/src/Text/Pandoc/Writers/ConTeXt.hs b/src/Text/Pandoc/Writers/ConTeXt.hs
index 13912a9f3..fbe677323 100644
--- a/src/Text/Pandoc/Writers/ConTeXt.hs
+++ b/src/Text/Pandoc/Writers/ConTeXt.hs
@@ -33,36 +33,44 @@ import Text.Pandoc.Shared
 import Text.Printf ( printf )
 import Data.List ( (\\), intersperse )
 import Control.Monad.State
+import Text.PrettyPrint.HughesPJ hiding ( Str )
 
 type WriterState = Int -- number of next URL reference 
 
 -- | Convert Pandoc to ConTeXt.
 writeConTeXt :: WriterOptions -> Pandoc -> String
-writeConTeXt options document = evalState (pandocToConTeXt options document) 1 
+writeConTeXt options document = render $ 
+  evalState (pandocToConTeXt options document) 1 
 
-pandocToConTeXt :: WriterOptions -> Pandoc -> State WriterState String
+pandocToConTeXt :: WriterOptions -> Pandoc -> State WriterState Doc
 pandocToConTeXt options (Pandoc meta blocks) = do
-  main    <- blockListToConTeXt blocks 
-  let body = writerIncludeBefore options ++ main ++ writerIncludeAfter options
+  main    <- blockListToConTeXt options blocks 
+  let before = if null (writerIncludeBefore options)
+                  then empty
+                  else text $ writerIncludeBefore options
+  let after  = if null (writerIncludeAfter options)
+                  then empty
+                  else text $ writerIncludeAfter options
+  let body = before $$ main $$ after
   head    <- if writerStandalone options
                 then contextHeader options meta
-                else return ""
+                else return empty
   let toc  = if writerTableOfContents options
-                then "\\placecontent\n\n"
-                else "" 
+                then text "\\placecontent\n"
+                else empty 
   let foot = if writerStandalone options
-                then "\n\\stoptext\n"
-                else ""
-  return $ head ++ toc ++ body ++ foot
+                then text "\\stoptext\n"
+                else empty 
+  return $ head $$ toc $$ body $$ foot
 
 -- | Insert bibliographic information into ConTeXt header.
 contextHeader :: WriterOptions -- ^ Options, including ConTeXt header
               -> Meta          -- ^ Meta with bibliographic information
-              -> State WriterState String
+              -> State WriterState Doc
 contextHeader options (Meta title authors date) = do
   titletext    <- if null title
-                     then return "" 
-                     else inlineListToConTeXt title
+                     then return empty 
+                     else inlineListToConTeXt options title
   let authorstext = if null authors
                        then ""
                        else if length authors == 1
@@ -72,14 +80,11 @@ contextHeader options (Meta title authors date) = do
   let datetext   = if date == ""
                        then "" 
                        else stringToConTeXt date
-  let titleblock = "\\doctitle{" ++ titletext ++ "}\n\
-                   \ \\author{" ++ authorstext ++ "}\n\
-                   \ \\date{" ++ datetext ++ "}\n\n"
-  let setupheads = if (writerNumberSections options)
-                      then "\\setupheads[sectionnumber=yes, style=\\bf]\n" 
-                      else "\\setupheads[sectionnumber=no, style=\\bf]\n"
-  let header     = writerHeader options
-  return $ header ++ setupheads ++ titleblock ++ "\\starttext\n\\maketitle\n\n"
+  let titleblock = text "\\doctitle{" <> titletext <> char '}' $$
+                   text ("\\author{" ++ authorstext ++ "}") $$
+                   text ("\\date{" ++ datetext ++ "}")
+  let header     = text $ writerHeader options
+  return $ header $$ titleblock $$ text "\\starttext\n\\maketitle\n"
 
 -- escape things as needed for ConTeXt
 
@@ -106,43 +111,49 @@ stringToConTeXt :: String -> String
 stringToConTeXt = concatMap escapeCharForConTeXt
 
 -- | Convert Pandoc block element to ConTeXt.
-blockToConTeXt :: Block -> State WriterState String 
-blockToConTeXt Null = return ""
-blockToConTeXt (Plain lst) = inlineListToConTeXt lst >>= return . (++ "\n")
-blockToConTeXt (Para lst) = inlineListToConTeXt lst >>= return . (++ "\n\n")
-blockToConTeXt (BlockQuote lst) = do
-  contents <- blockListToConTeXt lst
-  return $ "\\startblockquote\n" ++ contents ++ "\\stopblockquote\n\n"
-blockToConTeXt (CodeBlock str) = 
-  return $ "\\starttyping\n" ++ str ++ "\n\\stoptyping\n"
-blockToConTeXt (RawHtml str) = return ""
-blockToConTeXt (BulletList lst) = do 
-  contents <- mapM listItemToConTeXt lst
-  return $ "\\startltxitem\n" ++ concat contents ++ "\\stopltxitem\n"
-blockToConTeXt (OrderedList attribs lst) = case attribs of
+blockToConTeXt :: WriterOptions
+               -> Block 
+               -> State WriterState Doc 
+blockToConTeXt opts Null = return empty
+blockToConTeXt opts (Plain lst) = 
+  wrapTeXIfNeeded opts (inlineListToConTeXt opts) lst >>= return
+blockToConTeXt opts (Para lst) = 
+  wrapTeXIfNeeded opts (inlineListToConTeXt opts) lst >>= return . (<> char '\n')
+blockToConTeXt opts (BlockQuote lst) = do
+  contents <- blockListToConTeXt opts lst
+  return $ text "\\startblockquote" $$ contents $$ text "\\stopblockquote"
+blockToConTeXt opts (CodeBlock str) = 
+  return $ text $ "\\starttyping\n" ++ str ++ "\n\\stoptyping\n" -- \n needed
+  -- because \stoptyping can't have anything after it
+blockToConTeXt opts (RawHtml str) = return empty
+blockToConTeXt opts (BulletList lst) = do 
+  contents <- mapM (listItemToConTeXt opts) lst
+  return $ text "\\startltxitem" $$ vcat contents $$ text "\\stopltxitem"
+blockToConTeXt opts (OrderedList attribs lst) = case attribs of
   (1, DefaultStyle, DefaultDelim) -> do
-    contents <- mapM listItemToConTeXt lst
-    return $  "\\startltxenum\n" ++ concat contents ++ "\\stopltxenum\n"
+    contents <- mapM (listItemToConTeXt opts) lst
+    return $  text "\\startltxenum"$$ vcat contents $$ text "\\stopltxenum"
   _ -> do
     let markers = take (length lst) $ orderedListMarkers attribs
-    contents <- zipWithM orderedListItemToConTeXt markers lst
+    contents <- zipWithM (orderedListItemToConTeXt opts) markers lst
     let markerWidth = maximum $ map length markers 
     let markerWidth' = if markerWidth < 3
                           then ""
                           else "[width=" ++ 
                                show ((markerWidth + 2) `div` 2)  ++ "em]"
-    return $ "\\startitemize" ++ markerWidth' ++ "\n" ++ concat contents ++ 
-             "\\stopitemize\n"
-blockToConTeXt (DefinitionList lst) =
-  mapM defListItemToConTeXt lst >>= return . (++ "\n") . concat
-blockToConTeXt HorizontalRule = return "\\thinrule\n\n"
-blockToConTeXt (Header level lst) = do
-  contents <- inlineListToConTeXt lst
+    return $ text ("\\startitemize" ++ markerWidth') $$ vcat contents $$ 
+             text "\\stopitemize"
+blockToConTeXt opts (DefinitionList lst) =
+  mapM (defListItemToConTeXt opts) lst >>= return . (<> char '\n') . vcat
+blockToConTeXt opts HorizontalRule = return $ text "\\thinrule\n"
+blockToConTeXt opts (Header level lst) = do
+  contents <- inlineListToConTeXt opts lst
+  let base = if writerNumberSections opts then "section" else "subject"
   return $ if level > 0 && level <= 3
-              then "\\" ++ concat (replicate (level - 1) "sub") ++ 
-                   "section{" ++ contents ++ "}\n\n"
-              else contents ++ "\n\n"
-blockToConTeXt (Table caption aligns widths heads rows) = do
+              then char '\\' <> text (concat (replicate (level - 1) "sub")) <> 
+                   text base <> char '{' <> contents <> char '}' <> char '\n'
+              else contents <> char '\n'
+blockToConTeXt opts (Table caption aligns widths heads rows) = do
     let colWidths = map printDecimal widths
     let colDescriptor colWidth alignment = (case alignment of
                                                AlignLeft    -> 'l' 
@@ -152,43 +163,43 @@ blockToConTeXt (Table caption aligns widths heads rows) = do
                                            "p(" ++ colWidth ++ "\\textwidth)|"
     let colDescriptors = "|" ++ (concat $ 
                                  zipWith colDescriptor colWidths aligns)
-    headers <- tableRowToConTeXt heads 
-    captionText <- inlineListToConTeXt caption 
-    let captionText' = if null caption then "none" else captionText
-    rows' <- mapM tableRowToConTeXt rows 
-    return $ "\\placetable[here]{" ++ captionText' ++ "}\n\\starttable[" ++ 
-             colDescriptors ++ "]\n" ++ "\\HL\n" ++ headers ++ "\\HL\n" ++ 
-             concat rows' ++ "\\HL\n\\stoptable\n\n" 
+    headers <- tableRowToConTeXt opts heads 
+    captionText <- inlineListToConTeXt opts caption 
+    let captionText' = if null caption then text "none" else captionText
+    rows' <- mapM (tableRowToConTeXt opts) rows 
+    return $ text "\\placetable[here]{" <> captionText' <> char '}' $$
+             text "\\starttable[" <> text colDescriptors <> char ']' $$
+             text "\\HL" $$ headers $$ text "\\HL" $$
+             vcat rows' $$ text "\\HL\n\\stoptable\n" 
 
 printDecimal :: Float -> String
 printDecimal = printf "%.2f" 
 
-tableRowToConTeXt cols = do
-  cols' <- mapM blockListToConTeXt cols
-  return $ "\\NC " ++ (concat $ intersperse "\\NC " cols') ++ "\\NC\\AR\n"
+tableRowToConTeXt opts cols = do
+  cols' <- mapM (blockListToConTeXt opts) cols
+  return $ (vcat (map (text "\\NC " <>) cols')) $$ 
+           text "\\NC\\AR"
 
-listItemToConTeXt list = do
-  contents <- blockListToConTeXt list
-  return $ "\\item " ++ contents
+listItemToConTeXt opts list = blockListToConTeXt opts list >>=
+  return . (text "\\item " $$) . (nest 2)
 
-orderedListItemToConTeXt marker list = do
-  contents <- blockListToConTeXt list
-  return $ "\\sym{" ++ marker ++ "} " ++ contents
+orderedListItemToConTeXt opts marker list = blockListToConTeXt opts list >>=
+  return . (text ("\\sym{" ++ marker ++ "} ") $$) . (nest 2)
 
-defListItemToConTeXt (term, def) = do
-  term' <- inlineListToConTeXt term
-  def'  <- blockListToConTeXt def
-  return $ "\\startdescr{" ++ term' ++ "}\n" ++
-           def' ++ "\n\\stopdescr\n"
+defListItemToConTeXt opts (term, def) = do
+  term' <- inlineListToConTeXt opts term
+  def'  <- blockListToConTeXt opts def
+  return $ text "\\startdescr{" <> term' <> char '}' $$ def' $$ text "\\stopdescr"
 
 -- | Convert list of block elements to ConTeXt.
-blockListToConTeXt :: [Block] -> State WriterState String
-blockListToConTeXt lst = mapM blockToConTeXt lst >>= return . concat
+blockListToConTeXt :: WriterOptions -> [Block] -> State WriterState Doc
+blockListToConTeXt opts lst = mapM (blockToConTeXt opts) lst >>= return . vcat
 
 -- | Convert list of inline elements to ConTeXt.
-inlineListToConTeXt :: [Inline]  -- ^ Inlines to convert
-                    -> State WriterState String
-inlineListToConTeXt lst = mapM inlineToConTeXt lst >>= return . concat
+inlineListToConTeXt :: WriterOptions
+                    -> [Inline]  -- ^ Inlines to convert
+                    -> State WriterState Doc
+inlineListToConTeXt opts lst = mapM (inlineToConTeXt opts) lst >>= return . hcat
 
 isQuoted :: Inline -> Bool
 isQuoted (Quoted _ _) = True
@@ -196,53 +207,56 @@ isQuoted Apostrophe = True
 isQuoted _ = False
 
 -- | Convert inline element to ConTeXt
-inlineToConTeXt :: Inline    -- ^ Inline to convert
-                -> State WriterState String
-inlineToConTeXt (Emph lst) = do
-  contents <- inlineListToConTeXt lst
-  return $ "{\\em " ++ contents ++ "}" 
-inlineToConTeXt (Strong lst) = do
-  contents <- inlineListToConTeXt lst
-  return $ "{\\bf " ++ contents ++ "}" 
-inlineToConTeXt (Strikeout lst) = do
-  contents <- inlineListToConTeXt lst
-  return $ "\\overstrikes{" ++ contents ++ "}" 
-inlineToConTeXt (Superscript lst) = do
-  contents <- inlineListToConTeXt lst
-  return $ "\\high{" ++ contents ++ "}" 
-inlineToConTeXt (Subscript lst) = do
-  contents <- inlineListToConTeXt lst
-  return $ "\\low{" ++ contents ++ "}" 
-inlineToConTeXt (Code str) = return $ "\\type{" ++ str ++ "}"
-inlineToConTeXt (Quoted SingleQuote lst) = do
-  contents <- inlineListToConTeXt lst
-  return $ "\\quote{" ++ contents ++ "}"
-inlineToConTeXt (Quoted DoubleQuote lst) = do
-  contents <- inlineListToConTeXt lst
-  return $ "\\quotation{" ++ contents ++ "}"
-inlineToConTeXt Apostrophe = return "'"
-inlineToConTeXt EmDash = return "---"
-inlineToConTeXt EnDash = return "--"
-inlineToConTeXt Ellipses = return "\\ldots{}"
-inlineToConTeXt (Str str) = return $ stringToConTeXt str
-inlineToConTeXt (TeX str) = return str
-inlineToConTeXt (HtmlInline str) = return ""
-inlineToConTeXt (LineBreak) = return "\\crlf\n"
-inlineToConTeXt Space = return " "
-inlineToConTeXt (Link [Code str] (src, tit)) = -- since ConTeXt has its own 
-  inlineToConTeXt (Link [Str str] (src, tit))  -- way of printing links... 
-inlineToConTeXt (Link text (src, _)) = do
+inlineToConTeXt :: WriterOptions
+                -> Inline    -- ^ Inline to convert
+                -> State WriterState Doc
+inlineToConTeXt opts (Emph lst) = do 
+  contents <- inlineListToConTeXt opts lst
+  return $ text "{\\em " <> contents <> char '}'
+inlineToConTeXt opts (Strong lst) = do
+  contents <- inlineListToConTeXt opts lst
+  return $ text "{\\bf " <> contents <> char '}'
+inlineToConTeXt opts (Strikeout lst) = do
+  contents <- inlineListToConTeXt opts lst
+  return $ text "\\overstrikes{" <> contents <> char '}'
+inlineToConTeXt opts (Superscript lst) = do
+  contents <- inlineListToConTeXt opts lst
+  return $ text "\\high{" <> contents <> char '}'
+inlineToConTeXt opts (Subscript lst) = do
+  contents <- inlineListToConTeXt opts lst
+  return $ text "\\low{" <> contents <> char '}'
+inlineToConTeXt opts (Code str) = return $ text $ "\\type{" ++ str ++ "}"
+inlineToConTeXt opts (Quoted SingleQuote lst) = do
+  contents <- inlineListToConTeXt opts lst
+  return $ text "\\quote{" <> contents <> char '}'
+inlineToConTeXt opts (Quoted DoubleQuote lst) = do
+  contents <- inlineListToConTeXt opts lst
+  return $ text "\\quotation{" <> contents <> char '}'
+inlineToConTeXt opts Apostrophe = return $ char '\''
+inlineToConTeXt opts EmDash = return $ text "---"
+inlineToConTeXt opts EnDash = return $ text "--"
+inlineToConTeXt opts Ellipses = return $ text "\\ldots{}"
+inlineToConTeXt opts (Str str) = return $ text $ stringToConTeXt str
+inlineToConTeXt opts (TeX str) = return $ text str
+inlineToConTeXt opts (HtmlInline str) = return empty
+inlineToConTeXt opts (LineBreak) = return $ text "\\crlf\n"
+inlineToConTeXt opts Space = return $ char ' '
+inlineToConTeXt opts (Link [Code str] (src, tit)) = -- since ConTeXt has its own 
+  inlineToConTeXt opts (Link [Str str] (src, tit))  -- way of printing links... 
+inlineToConTeXt opts (Link txt (src, _)) = do
   next <- get
   put (next + 1)
   let ref = show next
-  label <- inlineListToConTeXt text
-  return $ "\\useurl[" ++ ref ++ "][" ++ src ++ "][][" ++ label ++ 
-           "]\\from[" ++ ref ++ "]" 
-inlineToConTeXt (Image alternate (src, tit)) = do
-  alt <- inlineListToConTeXt alternate
-  return $ "\\placefigure\n[]\n[fig:" ++ alt ++ "]\n{" ++
-           tit ++ "}\n{\\externalfigure[" ++ src ++ "]}" 
-inlineToConTeXt (Note contents) = do
-  contents' <- blockListToConTeXt contents
-  return $ "\\footnote{" ++ contents' ++ "}"
+  label <- inlineListToConTeXt opts txt
+  return $ text "\\useurl[" <> text ref <> text "][" <> text src <>
+           text "][][" <> label <> text "]\\from[" <> text ref <> char ']'
+inlineToConTeXt opts (Image alternate (src, tit)) = do
+  alt <- inlineListToConTeXt opts alternate
+  return $ text "\\placefigure\n[]\n[fig:" <> alt <> text "]\n{" <> 
+           text tit <> text "}\n{\\externalfigure[" <> text src <> text "]}" 
+inlineToConTeXt opts (Note contents) = do
+  contents' <- blockListToConTeXt opts contents
+  return $ text "\\footnote{" <> 
+           text (stripTrailingNewlines $ render contents') <> 
+           char '}'