path: root/src/Text/Pandoc/Writers/RST.hs

{-
Copyright (C) 2006-7 John MacFarlane <jgm@berkeley.edu>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

{- |
   Module      : Text.Pandoc.Writers.RST 
   Copyright   : Copyright (C) 2006-7 John MacFarlane
   License     : GNU GPL, version 2 or above 

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

Conversion of 'Pandoc' documents to reStructuredText.

reStructuredText:  <http://docutils.sourceforge.net/rst.html>
-}
module Text.Pandoc.Writers.RST (
                                     writeRST
                                    ) where
import Text.Pandoc.Definition
import Text.Pandoc.Shared 
import Text.Pandoc.Blocks
import Data.List ( group, isPrefixOf, drop, find, intersperse )
import Text.PrettyPrint.HughesPJ hiding ( Str )
import Control.Monad.State

type Notes = [[Block]]
type Refs = KeyTable
type WriterState = (Notes, Refs, Refs) -- first Refs is links, second pictures

-- | Convert Pandoc to RST.
writeRST :: WriterOptions -> Pandoc -> String
writeRST opts document = 
  render $ evalState (pandocToRST opts document) ([],[],[]) 

-- | Return RST representation of document.
pandocToRST :: WriterOptions -> Pandoc -> State WriterState Doc
pandocToRST opts (Pandoc meta blocks) = do
  let before  = writerIncludeBefore opts
  let after   = writerIncludeAfter opts
      before' = if null before then empty else text before
      after'  = if null after then empty else text after
  metaBlock <- metaToRST opts meta
  let head = if (writerStandalone opts)
                then metaBlock $$ text (writerHeader opts)
                else empty
  body <- blockListToRST opts blocks
  (notes, _, _) <- get
  notes' <- notesToRST opts (reverse notes)
  (_, refs, pics) <- get  -- note that the notes may contain refs
  refs' <- keyTableToRST opts (reverse refs)
  pics' <- pictTableToRST opts (reverse pics)
  return $ head <> (before' $$ body $$ notes' <> text "\n" $$ refs' $$ 
           pics' $$ after')

-- | Return RST representation of reference key table.
keyTableToRST :: WriterOptions -> KeyTable -> State WriterState Doc
keyTableToRST opts refs = 
  mapM (keyToRST opts) refs >>= (return . vcat)
 
-- | Return RST representation of a reference key. 
keyToRST :: WriterOptions 
         -> ([Inline], (String, String)) 
         -> State WriterState Doc
keyToRST opts (label, (src, tit)) = do
  label' <- inlineListToRST opts label
  return $ text ".. _" <> label' <> text ": " <> text src

-- | Return RST representation of notes.
notesToRST :: WriterOptions -> [[Block]] -> State WriterState Doc
notesToRST opts notes = 
  mapM (\(num, note) -> noteToRST opts num note) (zip [1..] notes) >>= 
  (return . vcat)

-- | Return RST representation of a note.
noteToRST :: WriterOptions -> Int -> [Block] -> State WriterState Doc
noteToRST opts num note = do
  contents <- blockListToRST opts note
  let marker = text ".. [" <> text (show num) <> text "] "
  return $ hang marker 3 contents 

-- | Return RST representation of picture reference table.
pictTableToRST :: WriterOptions -> KeyTable -> State WriterState Doc
pictTableToRST opts refs = 
  mapM (pictToRST opts) refs >>= (return . vcat)
 
-- | Return RST representation of a picture substitution reference. 
pictToRST :: WriterOptions 
         -> ([Inline], (String, String)) 
         -> State WriterState Doc
pictToRST opts (label, (src, _)) = do
  label' <- inlineListToRST opts label
  return $ text ".. " <> char '|' <> label' <> char '|' <> text " image:: " <>
           text src

-- | Take list of inline elements and return wrapped doc.
wrappedRST :: WriterOptions -> [Inline] -> State WriterState Doc
wrappedRST opts inlines = 
  mapM (wrappedRSTSection opts) (splitBy LineBreak inlines) >>= 
  (return . vcat)

wrappedRSTSection :: WriterOptions -> [Inline] -> State WriterState Doc
wrappedRSTSection opts sect = do
  let chunks = splitBy Space sect
  chunks' <- mapM (inlineListToRST opts) chunks
  return $ fsep chunks'

-- | Escape special characters for RST.
escapeString :: String -> String
escapeString = backslashEscape "`\\|*_"

-- | Convert bibliographic information into RST header.
metaToRST :: WriterOptions -> Meta -> State WriterState Doc
metaToRST opts (Meta title authors date) = do
  title'   <- titleToRST opts title
  authors' <- authorsToRST authors
  date'    <- dateToRST date
  let toc  =  if writerTableOfContents opts
                 then text "" $$ text ".. contents::"
                 else empty
  return $ title' $$ authors' $$ date' $$ toc $$ text ""

titleToRST :: WriterOptions -> [Inline] -> State WriterState Doc
titleToRST opts [] = return empty
titleToRST opts lst = do
  contents <- inlineListToRST opts lst
  let titleLength = length $ render contents
  let border = text (replicate titleLength '=')
  return $ border <> char '\n' <> contents <> char '\n' <> border <> text "\n"

authorsToRST :: [String] -> State WriterState Doc
authorsToRST [] = return empty
authorsToRST (first:rest) = do
  rest' <- authorsToRST rest
  return $ (text ":Author: " <> text first) $$ rest'

dateToRST :: String -> State WriterState Doc
dateToRST [] = return empty
dateToRST str = return $ text ":Date: " <> text (escapeString str)

-- | Convert Pandoc block element to RST. 
blockToRST :: WriterOptions -- ^ Options
                -> Block         -- ^ Block element
                -> State WriterState Doc 
blockToRST opts Null = return empty
blockToRST opts (Plain inlines) = wrappedRST opts inlines
blockToRST opts (Para [TeX str]) =
  let str' = if (endsWith '\n' str) then (str ++ "\n") else (str ++ "\n\n") in
  return $ hang (text "\n.. raw:: latex\n") 3 (vcat $ map text (lines str'))
blockToRST opts (Para inlines) = do
  contents <- wrappedRST opts inlines
  return $ contents <> text "\n"
blockToRST opts (RawHtml str) = 
  let str' = if (endsWith '\n' str) then (str ++ "\n") else (str ++ "\n\n") in
  return $ hang (text "\n.. raw:: html\n") 3 (vcat $ map text (lines str'))
blockToRST opts HorizontalRule = return $ text "--------------\n"
blockToRST opts (Header level inlines) = do
  contents <- inlineListToRST opts inlines
  let headerLength = length $ render contents
  let headerChar = if (level > 5) then ' ' else "=-~^'" !! (level - 1)
  let border = text $ replicate headerLength headerChar
  return $ contents <> char '\n' <> border <> char '\n'
blockToRST opts (CodeBlock str) = return $ (text "::\n") $$ text "" $$ 
  (nest (writerTabStop opts) $ vcat $ map text (lines str)) <> text "\n"
blockToRST opts (BlockQuote blocks) = do
  contents <- blockListToRST opts blocks 
  return $ (nest (writerTabStop opts) contents) <> text "\n"
blockToRST opts (Table caption aligns widths headers rows) =  do
  caption' <- inlineListToRST opts caption
  let caption'' = if null caption
                     then empty
                     else text "" $$ (text "Table: " <> caption')
  headers' <- mapM (blockListToRST opts) headers
  let widthsInChars = map (floor . (78 *)) widths
  let alignHeader alignment = case alignment of
                                AlignLeft    -> leftAlignBlock
                                AlignCenter  -> centerAlignBlock
                                AlignRight   -> rightAlignBlock
                                AlignDefault -> leftAlignBlock  
  let hpipeBlocks blocks = hcatBlocks [beg, middle, end] 
        where height = maximum (map heightOfBlock blocks)
              sep    = TextBlock 3 height (replicate height " | ")
              beg    = TextBlock 2 height (replicate height "| ")
              end    = TextBlock 2 height (replicate height " |")
              middle = hcatBlocks $ intersperse sep blocks
  let makeRow = hpipeBlocks . (zipWith docToBlock widthsInChars)
  let head = makeRow headers'
  rows' <- mapM (\row -> do 
                           cols <- mapM (blockListToRST opts) row
                           return $ makeRow cols) rows
  let tableWidth = sum widthsInChars
  let maxRowHeight = maximum $ map heightOfBlock (head:rows')
  let border ch = char '+' <> char ch <>
                  (hcat $ intersperse (char ch <> char '+' <> char ch) $ 
                          map (\l -> text $ replicate l ch) widthsInChars) <>
                  char ch <> char '+'
  let body = vcat $ intersperse (border '-') $ map blockToDoc rows'
  return $ border '-' $$ blockToDoc head $$ border '=' $$ body $$ 
           border '-' $$ caption'' $$ text ""
blockToRST opts (BulletList items) = do
  contents <- mapM (bulletListItemToRST opts) items
  return $ (vcat contents) <> text "\n"
blockToRST opts (OrderedList items) = do
  contents <- mapM (\(item, num) -> orderedListItemToRST opts item num) $
              zip [1..] items  
  return $ (vcat contents) <> text "\n"
blockToRST opts (DefinitionList items) = do
  contents <- mapM (definitionListItemToRST opts) items
  return $ (vcat contents) <> text "\n"

-- | Convert bullet list item (list of blocks) to RST.
bulletListItemToRST :: WriterOptions -> [Block] -> State WriterState Doc
bulletListItemToRST opts items = do
  contents <- blockListToRST opts items
  return $ hang (text "-  ") (writerTabStop opts) contents

-- | Convert ordered list item (a list of blocks) to RST.
orderedListItemToRST :: WriterOptions -- ^ options
                          -> Int           -- ^ ordinal number of list item
                          -> [Block]       -- ^ list item (list of blocks)
                          -> State WriterState Doc
orderedListItemToRST opts num items = do
  contents <- blockListToRST opts items
  let spacer = if (num < 10) then " " else ""
  return $ hang (text ((show num) ++ "." ++ spacer)) (writerTabStop opts)
           contents 

-- | Convert defintion list item (label, list of blocks) to RST.
definitionListItemToRST :: WriterOptions -> ([Inline], [Block]) -> State WriterState Doc
definitionListItemToRST opts (label, items) = do
  label <- inlineListToRST opts label
  contents <- blockListToRST opts items
  return $ label $+$ nest (writerTabStop opts) contents

-- | Convert list of Pandoc block elements to RST.
blockListToRST :: WriterOptions -- ^ Options
                    -> [Block]       -- ^ List of block elements
                    -> State WriterState Doc 
blockListToRST opts blocks =
  mapM (blockToRST opts) blocks >>= (return . vcat)

-- | Convert list of Pandoc inline elements to RST.
inlineListToRST :: WriterOptions -> [Inline] -> State WriterState Doc
inlineListToRST opts lst = mapM (inlineToRST opts) lst >>= (return . hcat)

-- | Convert Pandoc inline element to RST.
inlineToRST :: WriterOptions -> Inline -> State WriterState Doc
inlineToRST opts (Emph lst) = do 
  contents <- inlineListToRST opts lst
  return $ text "*" <> contents <> text "*"
inlineToRST opts (Strong lst) = do
  contents <- inlineListToRST opts lst
  return $ text "**" <> contents <> text "**"
inlineToRST opts (Quoted SingleQuote lst) = do
  contents <- inlineListToRST opts lst
  return $ char '\'' <> contents <> char '\''
inlineToRST opts (Quoted DoubleQuote lst) = do
  contents <- inlineListToRST opts lst
  return $ char '"' <> contents <> char '"'
inlineToRST opts EmDash = return $ text "--"
inlineToRST opts EnDash = return $ char '-'
inlineToRST opts Apostrophe = return $ char '\''
inlineToRST opts Ellipses = return $ text "..."
inlineToRST opts (Code str) = return $ text $ "``" ++ str ++ "``"
inlineToRST opts (Str str) = return $ text $ escapeString str
inlineToRST opts (TeX str) = return $ text str
inlineToRST opts (HtmlInline str) = return empty
inlineToRST opts (LineBreak) = return $ text " " -- RST doesn't have linebreaks 
inlineToRST opts Space = return $ char ' '
inlineToRST opts (Link txt (src, tit)) = do
  let useReferenceLinks = writerReferenceLinks opts
  let srcSuffix = if isPrefixOf "mailto:" src then drop 7 src else src
  let useAuto = null tit && txt == [Str srcSuffix]
  (notes, refs, pics) <- get
  linktext <- inlineListToRST opts $ normalizeSpaces txt
  link <- if useReferenceLinks
             then do let refs' = if (txt, (src, tit)) `elem` refs
                                    then refs
                                    else (txt, (src, tit)):refs
                     put (notes, refs', pics)
                     return $ char '`' <> linktext <> text "`_"
             else return $ char '`' <> linktext <> text " <" <>
                           text src <> text ">`_"
  return link
inlineToRST opts (Image alternate (source, tit)) = do
  (notes, refs, pics) <- get
  let labelsUsed = map fst pics 
  let txt = if (null alternate) || (alternate == [Str ""]) || 
               (alternate `elem` labelsUsed)
               then [Str $ "image" ++ show (length refs)]
               else alternate
  let pics' = if (txt, (source, tit)) `elem` pics
                 then pics
                 else (txt, (source, tit)):pics
  put (notes, refs, pics')
  label <- inlineListToRST opts txt
  return $ char '|' <> label <> char '|'
inlineToRST opts (Note contents) = do 
  -- add to notes in state
  modify (\(notes, refs, pics) -> (contents:notes, refs, pics))
  (notes, _, _) <- get
  let ref = show $ (length notes)
  return $ text " [" <> text ref <> text "]_"