338 lines
14 KiB
Haskell
338 lines
14 KiB
Haskell
{-
|
|
Copyright (C) 2006-2010 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-2010 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 Text.Pandoc.Templates (renderTemplate)
|
|
import Data.List ( isPrefixOf, isSuffixOf, intersperse, transpose )
|
|
import Text.PrettyPrint.HughesPJ hiding ( Str )
|
|
import Control.Monad.State
|
|
import Control.Applicative ( (<$>) )
|
|
|
|
data WriterState =
|
|
WriterState { stNotes :: [[Block]]
|
|
, stLinks :: KeyTable
|
|
, stImages :: KeyTable
|
|
, stHasMath :: Bool
|
|
, stOptions :: WriterOptions
|
|
}
|
|
|
|
-- | Convert Pandoc to RST.
|
|
writeRST :: WriterOptions -> Pandoc -> String
|
|
writeRST opts document =
|
|
let st = WriterState { stNotes = [], stLinks = [],
|
|
stImages = [], stHasMath = False,
|
|
stOptions = opts }
|
|
in evalState (pandocToRST document) st
|
|
|
|
-- | Return RST representation of document.
|
|
pandocToRST :: Pandoc -> State WriterState String
|
|
pandocToRST (Pandoc (Meta tit auth dat) blocks) = do
|
|
opts <- liftM stOptions get
|
|
title <- titleToRST tit
|
|
authors <- mapM inlineListToRST auth
|
|
date <- inlineListToRST dat
|
|
body <- blockListToRST blocks
|
|
notes <- liftM (reverse . stNotes) get >>= notesToRST
|
|
-- note that the notes may contain refs, so we do them first
|
|
refs <- liftM (reverse . stLinks) get >>= keyTableToRST
|
|
pics <- liftM (reverse . stImages) get >>= pictTableToRST
|
|
hasMath <- liftM stHasMath get
|
|
let main = render $ body $+$ notes $+$ text "" $+$ refs $+$ pics
|
|
let context = writerVariables opts ++
|
|
[ ("body", main)
|
|
, ("title", render title)
|
|
, ("date", render date) ] ++
|
|
[ ("math", "yes") | hasMath ] ++
|
|
[ ("author", render a) | a <- authors ]
|
|
if writerStandalone opts
|
|
then return $ renderTemplate context $ writerTemplate opts
|
|
else return main
|
|
|
|
-- | Return RST representation of reference key table.
|
|
keyTableToRST :: KeyTable -> State WriterState Doc
|
|
keyTableToRST refs = mapM keyToRST refs >>= return . vcat
|
|
|
|
-- | Return RST representation of a reference key.
|
|
keyToRST :: ([Inline], (String, String))
|
|
-> State WriterState Doc
|
|
keyToRST (label, (src, _)) = do
|
|
label' <- inlineListToRST label
|
|
let label'' = if ':' `elem` (render label')
|
|
then char '`' <> label' <> char '`'
|
|
else label'
|
|
return $ text ".. _" <> label'' <> text ": " <> text src
|
|
|
|
-- | Return RST representation of notes.
|
|
notesToRST :: [[Block]] -> State WriterState Doc
|
|
notesToRST notes =
|
|
mapM (\(num, note) -> noteToRST num note) (zip [1..] notes) >>=
|
|
return . vcat
|
|
|
|
-- | Return RST representation of a note.
|
|
noteToRST :: Int -> [Block] -> State WriterState Doc
|
|
noteToRST num note = do
|
|
contents <- blockListToRST note
|
|
let marker = text ".. [" <> text (show num) <> text "]"
|
|
return $ marker $$ nest 3 contents
|
|
|
|
-- | Return RST representation of picture reference table.
|
|
pictTableToRST :: KeyTable -> State WriterState Doc
|
|
pictTableToRST refs = mapM pictToRST refs >>= return . vcat
|
|
|
|
-- | Return RST representation of a picture substitution reference.
|
|
pictToRST :: ([Inline], (String, String))
|
|
-> State WriterState Doc
|
|
pictToRST (label, (src, _)) = do
|
|
label' <- inlineListToRST 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 = do
|
|
lineBreakDoc <- inlineToRST LineBreak
|
|
chunks <- mapM (wrapIfNeeded opts inlineListToRST)
|
|
(splitBy LineBreak inlines)
|
|
return $ vcat $ intersperse lineBreakDoc chunks
|
|
|
|
-- | Escape special characters for RST.
|
|
escapeString :: String -> String
|
|
escapeString = escapeStringUsing (backslashEscapes "`\\|*_")
|
|
|
|
titleToRST :: [Inline] -> State WriterState Doc
|
|
titleToRST [] = return empty
|
|
titleToRST lst = do
|
|
contents <- inlineListToRST lst
|
|
let titleLength = length $ render contents
|
|
let border = text (replicate titleLength '=')
|
|
return $ border $+$ contents $+$ border
|
|
|
|
-- | Convert Pandoc block element to RST.
|
|
blockToRST :: Block -- ^ Block element
|
|
-> State WriterState Doc
|
|
blockToRST Null = return empty
|
|
blockToRST (Plain inlines) = do
|
|
opts <- get >>= (return . stOptions)
|
|
wrappedRST opts inlines
|
|
blockToRST (Para [Image txt (src,tit)]) = do
|
|
capt <- inlineListToRST txt
|
|
let fig = text "figure:: " <> text src
|
|
let align = text ":align: center"
|
|
let alt = text ":alt: " <> if null tit then capt else text tit
|
|
return $ (text ".. " <> (fig $$ align $$ alt $$ text "" $$ capt)) $$ text ""
|
|
blockToRST (Para inlines) = do
|
|
opts <- get >>= (return . stOptions)
|
|
contents <- wrappedRST opts inlines
|
|
return $ contents <> text "\n"
|
|
blockToRST (RawHtml str) =
|
|
let str' = if "\n" `isSuffixOf` str then str ++ "\n" else str ++ "\n\n" in
|
|
return $ (text "\n.. raw:: html\n") $$ (nest 3 $ vcat $ map text (lines str'))
|
|
blockToRST HorizontalRule = return $ text "--------------\n"
|
|
blockToRST (Header level inlines) = do
|
|
contents <- inlineListToRST inlines
|
|
let headerLength = length $ render contents
|
|
let headerChar = if level > 5 then ' ' else "=-~^'" !! (level - 1)
|
|
let border = text $ replicate headerLength headerChar
|
|
return $ contents $+$ border <> text "\n"
|
|
blockToRST (CodeBlock (_,classes,_) str) = do
|
|
opts <- stOptions <$> get
|
|
let tabstop = writerTabStop opts
|
|
if "haskell" `elem` classes && "literate" `elem` classes &&
|
|
writerLiterateHaskell opts
|
|
then return $ (vcat $ map (text "> " <>) $ map text (lines str)) <> text "\n"
|
|
else return $ (text "::\n") $+$
|
|
(nest tabstop $ vcat $ map text (lines str)) <> text "\n"
|
|
blockToRST (BlockQuote blocks) = do
|
|
tabstop <- get >>= (return . writerTabStop . stOptions)
|
|
contents <- blockListToRST blocks
|
|
return $ (nest tabstop contents) <> text "\n"
|
|
blockToRST (Table caption _ widths headers rows) = do
|
|
caption' <- inlineListToRST caption
|
|
let caption'' = if null caption
|
|
then empty
|
|
else text "" $+$ (text "Table: " <> caption')
|
|
headers' <- mapM blockListToRST headers
|
|
rawRows <- mapM (mapM blockListToRST) rows
|
|
let isSimple = all (==0) widths && all (all (\bs -> length bs == 1)) rows
|
|
let numChars = maximum . map (length . render)
|
|
let widthsInChars =
|
|
if isSimple
|
|
then map ((+2) . numChars) $ transpose (headers' : rawRows)
|
|
else map (floor . (78 *)) widths
|
|
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 row
|
|
return $ makeRow cols) 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'
|
|
let head'' = if all null headers
|
|
then empty
|
|
else blockToDoc head' $+$ border '='
|
|
return $ border '-' $+$ head'' $+$ body $+$ border '-' $$ caption'' $$ text ""
|
|
blockToRST (BulletList items) = do
|
|
contents <- mapM bulletListItemToRST items
|
|
-- ensure that sublists have preceding blank line
|
|
return $ text "" $+$ vcat contents <> text "\n"
|
|
blockToRST (OrderedList (start, style', delim) items) = do
|
|
let markers = if start == 1 && style' == DefaultStyle && delim == DefaultDelim
|
|
then take (length items) $ repeat "#."
|
|
else take (length items) $ orderedListMarkers
|
|
(start, style', delim)
|
|
let maxMarkerLength = maximum $ map length markers
|
|
let markers' = map (\m -> let s = maxMarkerLength - length m
|
|
in m ++ replicate s ' ') markers
|
|
contents <- mapM (\(item, num) -> orderedListItemToRST item num) $
|
|
zip markers' items
|
|
-- ensure that sublists have preceding blank line
|
|
return $ text "" $+$ vcat contents <> text "\n"
|
|
blockToRST (DefinitionList items) = do
|
|
contents <- mapM definitionListItemToRST items
|
|
return $ (vcat contents) <> text "\n"
|
|
|
|
-- | Convert bullet list item (list of blocks) to RST.
|
|
bulletListItemToRST :: [Block] -> State WriterState Doc
|
|
bulletListItemToRST items = do
|
|
contents <- blockListToRST items
|
|
return $ (text "- ") <> contents
|
|
|
|
-- | Convert ordered list item (a list of blocks) to RST.
|
|
orderedListItemToRST :: String -- ^ marker for list item
|
|
-> [Block] -- ^ list item (list of blocks)
|
|
-> State WriterState Doc
|
|
orderedListItemToRST marker items = do
|
|
contents <- blockListToRST items
|
|
return $ (text marker <> char ' ') <> contents
|
|
|
|
-- | Convert defintion list item (label, list of blocks) to RST.
|
|
definitionListItemToRST :: ([Inline], [[Block]]) -> State WriterState Doc
|
|
definitionListItemToRST (label, defs) = do
|
|
label' <- inlineListToRST label
|
|
contents <- liftM vcat $ mapM blockListToRST defs
|
|
tabstop <- get >>= (return . writerTabStop . stOptions)
|
|
return $ label' $+$ nest tabstop contents
|
|
|
|
-- | Convert list of Pandoc block elements to RST.
|
|
blockListToRST :: [Block] -- ^ List of block elements
|
|
-> State WriterState Doc
|
|
blockListToRST blocks = mapM blockToRST blocks >>= return . vcat
|
|
|
|
-- | Convert list of Pandoc inline elements to RST.
|
|
inlineListToRST :: [Inline] -> State WriterState Doc
|
|
inlineListToRST lst = mapM inlineToRST lst >>= return . hcat
|
|
|
|
-- | Convert Pandoc inline element to RST.
|
|
inlineToRST :: Inline -> State WriterState Doc
|
|
inlineToRST (Emph lst) = do
|
|
contents <- inlineListToRST lst
|
|
return $ char '*' <> contents <> char '*'
|
|
inlineToRST (Strong lst) = do
|
|
contents <- inlineListToRST lst
|
|
return $ text "**" <> contents <> text "**"
|
|
inlineToRST (Strikeout lst) = do
|
|
contents <- inlineListToRST lst
|
|
return $ text "[STRIKEOUT:" <> contents <> char ']'
|
|
inlineToRST (Superscript lst) = do
|
|
contents <- inlineListToRST lst
|
|
return $ text "\\ :sup:`" <> contents <> text "`\\ "
|
|
inlineToRST (Subscript lst) = do
|
|
contents <- inlineListToRST lst
|
|
return $ text "\\ :sub:`" <> contents <> text "`\\ "
|
|
inlineToRST (SmallCaps lst) = inlineListToRST lst
|
|
inlineToRST (Quoted SingleQuote lst) = do
|
|
contents <- inlineListToRST lst
|
|
return $ char '\'' <> contents <> char '\''
|
|
inlineToRST (Quoted DoubleQuote lst) = do
|
|
contents <- inlineListToRST lst
|
|
return $ char '"' <> contents <> char '"'
|
|
inlineToRST (Cite _ lst) =
|
|
inlineListToRST lst
|
|
inlineToRST EmDash = return $ text "--"
|
|
inlineToRST EnDash = return $ char '-'
|
|
inlineToRST Apostrophe = return $ char '\''
|
|
inlineToRST Ellipses = return $ text "..."
|
|
inlineToRST (Code str) = return $ text $ "``" ++ str ++ "``"
|
|
inlineToRST (Str str) = return $ text $ escapeString str
|
|
inlineToRST (Math t str) = do
|
|
modify $ \st -> st{ stHasMath = True }
|
|
return $ if t == InlineMath
|
|
then text $ ":math:`$" ++ str ++ "$`"
|
|
else text $ ":math:`$$" ++ str ++ "$$`"
|
|
inlineToRST (TeX _) = return empty
|
|
inlineToRST (HtmlInline _) = return empty
|
|
inlineToRST (LineBreak) = do
|
|
return $ empty -- there's no line break in RST
|
|
inlineToRST Space = return $ char ' '
|
|
inlineToRST (Link [Code str] (src, _)) | src == str ||
|
|
src == "mailto:" ++ str = do
|
|
let srcSuffix = if isPrefixOf "mailto:" src then drop 7 src else src
|
|
return $ text srcSuffix
|
|
inlineToRST (Link txt (src, tit)) = do
|
|
useReferenceLinks <- get >>= (return . writerReferenceLinks . stOptions)
|
|
linktext <- inlineListToRST $ normalizeSpaces txt
|
|
if useReferenceLinks
|
|
then do refs <- get >>= (return . stLinks)
|
|
let refs' = if (txt, (src, tit)) `elem` refs
|
|
then refs
|
|
else (txt, (src, tit)):refs
|
|
modify $ \st -> st { stLinks = refs' }
|
|
return $ char '`' <> linktext <> text "`_"
|
|
else return $ char '`' <> linktext <> text " <" <> text src <> text ">`_"
|
|
inlineToRST (Image alternate (source, tit)) = do
|
|
pics <- get >>= (return . stImages)
|
|
let labelsUsed = map fst pics
|
|
let txt = if null alternate || alternate == [Str ""] ||
|
|
alternate `elem` labelsUsed
|
|
then [Str $ "image" ++ show (length pics)]
|
|
else alternate
|
|
let pics' = if (txt, (source, tit)) `elem` pics
|
|
then pics
|
|
else (txt, (source, tit)):pics
|
|
modify $ \st -> st { stImages = pics' }
|
|
label <- inlineListToRST txt
|
|
return $ char '|' <> label <> char '|'
|
|
inlineToRST (Note contents) = do
|
|
-- add to notes in state
|
|
notes <- get >>= (return . stNotes)
|
|
modify $ \st -> st { stNotes = contents:notes }
|
|
let ref = show $ (length notes) + 1
|
|
return $ text " [" <> text ref <> text "]_"
|