Tissevert/pandoc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions 1

Refactored RST writer to usea record instead of a tuple for state,

Browse source 
and to include options in state so it doesn't need to be passed as
a parameter.


git-svn-id: https://pandoc.googlecode.com/svn/trunk@1167 788f1e2b-df1e-0410-8736-df70ead52e1b
This commit is contained in:
fiddlosopher 2008-01-04 18:58:50 +00:00
parent 5df912b162
commit ec3f6b649f
1 changed files with 135 additions and 125 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

260
Text/Pandoc/Writers/RST.hs
View file

@ -40,16 +40,26 @@ import Control.Monad.State
type Notes = [[Block]] type Notes = [[Block]]
type Refs = KeyTable type Refs = KeyTable
type WriterState = (Notes, Refs, Refs) -- first Refs is links, second pictures data WriterState =
WriterState { stNotes :: [[Block]]
, stLinks :: KeyTable
, stImages :: KeyTable
, stIncludes :: [Doc]
, stOptions :: WriterOptions
}
-- | Convert Pandoc to RST. -- | Convert Pandoc to RST.
writeRST :: WriterOptions -> Pandoc -> String writeRST :: WriterOptions -> Pandoc -> String
writeRST opts document = writeRST opts document =
render $ evalState (pandocToRST opts document) ([],[],[]) let st = WriterState { stNotes = [], stLinks = [],
stImages = [], stIncludes = [],
stOptions = opts }
in render $ evalState (pandocToRST document) st
-- | Return RST representation of document. -- | Return RST representation of document.
pandocToRST :: WriterOptions -> Pandoc -> State WriterState Doc pandocToRST :: Pandoc -> State WriterState Doc
pandocToRST opts (Pandoc meta blocks) = do pandocToRST (Pandoc meta blocks) = do
opts <- get >>= (return . stOptions)
let before = writerIncludeBefore opts let before = writerIncludeBefore opts
let after = writerIncludeAfter opts let after = writerIncludeAfter opts
before' = if null before then empty else text before before' = if null before then empty else text before
@ -58,60 +68,57 @@ pandocToRST opts (Pandoc meta blocks) = do
let head = if (writerStandalone opts) let head = if (writerStandalone opts)
then metaBlock $+$ text (writerHeader opts) then metaBlock $+$ text (writerHeader opts)
else empty else empty
body <- blockListToRST opts blocks body <- blockListToRST blocks
(notes, _, _) <- get notes <- get >>= (notesToRST . reverse . stNotes)
notes' <- notesToRST opts (reverse notes) -- note that the notes may contain refs, so we do them first
(_, refs, pics) <- get -- note that the notes may contain refs refs <- get >>= (keyTableToRST . reverse . stLinks)
refs' <- keyTableToRST opts (reverse refs) pics <- get >>= (pictTableToRST . reverse . stImages)
pics' <- pictTableToRST opts (reverse pics) return $ head $+$ before' $+$ body $+$ notes $+$ text "" $+$ refs $+$
return $ head $+$ before' $+$ body $+$ notes' $+$ text "" $+$ refs' $+$ pics $+$ after'
pics' $+$ after'
-- | Return RST representation of reference key table. -- | Return RST representation of reference key table.
keyTableToRST :: WriterOptions -> KeyTable -> State WriterState Doc keyTableToRST :: KeyTable -> State WriterState Doc
keyTableToRST opts refs = mapM (keyToRST opts) refs >>= return . vcat keyTableToRST refs = mapM keyToRST refs >>= return . vcat
-- | Return RST representation of a reference key. -- | Return RST representation of a reference key.
keyToRST :: WriterOptions keyToRST :: ([Inline], (String, String))
-> ([Inline], (String, String))
-> State WriterState Doc -> State WriterState Doc
keyToRST opts (label, (src, tit)) = do keyToRST (label, (src, tit)) = do
label' <- inlineListToRST opts label label' <- inlineListToRST label
let label'' = if ':' `elem` (render label') let label'' = if ':' `elem` (render label')
then char '`' <> label' <> char '`' then char '`' <> label' <> char '`'
else label' else label'
return $ text ".. _" <> label'' <> text ": " <> text src return $ text ".. _" <> label'' <> text ": " <> text src
-- | Return RST representation of notes. -- | Return RST representation of notes.
notesToRST :: WriterOptions -> [[Block]] -> State WriterState Doc notesToRST :: [[Block]] -> State WriterState Doc
notesToRST opts notes = notesToRST notes =
mapM (\(num, note) -> noteToRST opts num note) (zip [1..] notes) >>= mapM (\(num, note) -> noteToRST num note) (zip [1..] notes) >>=
return . vcat return . vcat
-- | Return RST representation of a note. -- | Return RST representation of a note.
noteToRST :: WriterOptions -> Int -> [Block] -> State WriterState Doc noteToRST :: Int -> [Block] -> State WriterState Doc
noteToRST opts num note = do noteToRST num note = do
contents <- blockListToRST opts note contents <- blockListToRST note
let marker = text ".. [" <> text (show num) <> text "] " let marker = text ".. [" <> text (show num) <> text "] "
return $ hang marker 3 contents return $ hang marker 3 contents
-- | Return RST representation of picture reference table. -- | Return RST representation of picture reference table.
pictTableToRST :: WriterOptions -> KeyTable -> State WriterState Doc pictTableToRST :: KeyTable -> State WriterState Doc
pictTableToRST opts refs = mapM (pictToRST opts) refs >>= return . vcat pictTableToRST refs = mapM pictToRST refs >>= return . vcat
-- | Return RST representation of a picture substitution reference. -- | Return RST representation of a picture substitution reference.
pictToRST :: WriterOptions pictToRST :: ([Inline], (String, String))
-> ([Inline], (String, String)) -> State WriterState Doc
-> State WriterState Doc pictToRST (label, (src, _)) = do
pictToRST opts (label, (src, _)) = do label' <- inlineListToRST label
label' <- inlineListToRST opts label
return $ text ".. " <> char '|' <> label' <> char '|' <> text " image:: " <> return $ text ".. " <> char '|' <> label' <> char '|' <> text " image:: " <>
text src text src
-- | Take list of inline elements and return wrapped doc. -- | Take list of inline elements and return wrapped doc.
wrappedRST :: WriterOptions -> [Inline] -> State WriterState Doc wrappedRST :: WriterOptions -> [Inline] -> State WriterState Doc
wrappedRST opts inlines = mapM (wrapIfNeeded opts (inlineListToRST opts)) wrappedRST opts inlines = mapM (wrapIfNeeded opts inlineListToRST)
(splitBy LineBreak inlines) >>= return . vcat (splitBy LineBreak inlines) >>= return . vcat
-- | Escape special characters for RST. -- | Escape special characters for RST.
escapeString :: String -> String escapeString :: String -> String
@ -120,7 +127,7 @@ escapeString = escapeStringUsing (backslashEscapes "`\\|*_")
-- | Convert bibliographic information into RST header. -- | Convert bibliographic information into RST header.
metaToRST :: WriterOptions -> Meta -> State WriterState Doc metaToRST :: WriterOptions -> Meta -> State WriterState Doc
metaToRST opts (Meta title authors date) = do metaToRST opts (Meta title authors date) = do
title' <- titleToRST opts title title' <- titleToRST title
authors' <- authorsToRST authors authors' <- authorsToRST authors
date' <- dateToRST date date' <- dateToRST date
let toc = if writerTableOfContents opts let toc = if writerTableOfContents opts
@ -128,10 +135,10 @@ metaToRST opts (Meta title authors date) = do
else empty else empty
return $ title' $+$ authors' $+$ date' $+$ toc return $ title' $+$ authors' $+$ date' $+$ toc
titleToRST :: WriterOptions -> [Inline] -> State WriterState Doc titleToRST :: [Inline] -> State WriterState Doc
titleToRST opts [] = return empty titleToRST [] = return empty
titleToRST opts lst = do titleToRST lst = do
contents <- inlineListToRST opts lst contents <- inlineListToRST lst
let titleLength = length $ render contents let titleLength = length $ render contents
let border = text (replicate titleLength '=') let border = text (replicate titleLength '=')
return $ border $+$ contents $+$ border <> text "\n" return $ border $+$ contents $+$ border <> text "\n"
@ -147,35 +154,40 @@ dateToRST [] = return empty
dateToRST str = return $ text ":Date: " <> text (escapeString str) dateToRST str = return $ text ":Date: " <> text (escapeString str)
-- | Convert Pandoc block element to RST. -- | Convert Pandoc block element to RST.
blockToRST :: WriterOptions -- ^ Options blockToRST :: Block -- ^ Block element
-> Block -- ^ Block element -> State WriterState Doc
-> State WriterState Doc blockToRST Null = return empty
blockToRST opts Null = return empty blockToRST (Plain inlines) = do
blockToRST opts (Plain inlines) = wrappedRST opts inlines opts <- get >>= (return . stOptions)
blockToRST opts (Para inlines) = do wrappedRST opts inlines
blockToRST (Para inlines) = do
opts <- get >>= (return . stOptions)
contents <- wrappedRST opts inlines contents <- wrappedRST opts inlines
return $ contents <> text "\n" return $ contents <> text "\n"
blockToRST opts (RawHtml str) = blockToRST (RawHtml str) =
let str' = if "\n" `isSuffixOf` str then str ++ "\n" else str ++ "\n\n" in let str' = if "\n" `isSuffixOf` str then str ++ "\n" else str ++ "\n\n" in
return $ hang (text "\n.. raw:: html\n") 3 $ vcat $ map text (lines str') return $ hang (text "\n.. raw:: html\n") 3 $ vcat $ map text (lines str')
blockToRST opts HorizontalRule = return $ text "--------------\n" blockToRST HorizontalRule = return $ text "--------------\n"
blockToRST opts (Header level inlines) = do blockToRST (Header level inlines) = do
contents <- inlineListToRST opts inlines contents <- inlineListToRST inlines
let headerLength = length $ render contents let headerLength = length $ render contents
let headerChar = if level > 5 then ' ' else "=-~^'" !! (level - 1) let headerChar = if level > 5 then ' ' else "=-~^'" !! (level - 1)
let border = text $ replicate headerLength headerChar let border = text $ replicate headerLength headerChar
return $ contents $+$ border <> text "\n" return $ contents $+$ border <> text "\n"
blockToRST opts (CodeBlock str) = return $ (text "::\n") $+$ blockToRST (CodeBlock str) = do
(nest (writerTabStop opts) $ vcat $ map text (lines str)) <> text "\n" tabstop <- get >>= (return . writerTabStop . stOptions)
blockToRST opts (BlockQuote blocks) = do return $ (text "::\n") $+$
contents <- blockListToRST opts blocks (nest tabstop $ vcat $ map text (lines str)) <> text "\n"
return $ (nest (writerTabStop opts) contents) <> text "\n" blockToRST (BlockQuote blocks) = do
blockToRST opts (Table caption aligns widths headers rows) = do tabstop <- get >>= (return . writerTabStop . stOptions)
caption' <- inlineListToRST opts caption contents <- blockListToRST blocks
return $ (nest tabstop contents) <> text "\n"
blockToRST (Table caption aligns widths headers rows) = do
caption' <- inlineListToRST caption
let caption'' = if null caption let caption'' = if null caption
then empty then empty
else text "" $+$ (text "Table: " <> caption') else text "" $+$ (text "Table: " <> caption')
headers' <- mapM (blockListToRST opts) headers headers' <- mapM blockListToRST headers
let widthsInChars = map (floor . (78 *)) widths let widthsInChars = map (floor . (78 *)) widths
let alignHeader alignment = case alignment of let alignHeader alignment = case alignment of
AlignLeft -> leftAlignBlock AlignLeft -> leftAlignBlock
@ -190,7 +202,7 @@ blockToRST opts (Table caption aligns widths headers rows) = do
middle = hcatBlocks $ intersperse sep blocks middle = hcatBlocks $ intersperse sep blocks
let makeRow = hpipeBlocks . zipWith docToBlock widthsInChars let makeRow = hpipeBlocks . zipWith docToBlock widthsInChars
let head = makeRow headers' let head = makeRow headers'
rows' <- mapM (\row -> do cols <- mapM (blockListToRST opts) row rows' <- mapM (\row -> do cols <- mapM blockListToRST row
return $ makeRow cols) rows return $ makeRow cols) rows
let tableWidth = sum widthsInChars let tableWidth = sum widthsInChars
let maxRowHeight = maximum $ map heightOfBlock (head:rows') let maxRowHeight = maximum $ map heightOfBlock (head:rows')
@ -201,11 +213,11 @@ blockToRST opts (Table caption aligns widths headers rows) = do
let body = vcat $ intersperse (border '-') $ map blockToDoc rows' let body = vcat $ intersperse (border '-') $ map blockToDoc rows'
return $ border '-' $+$ blockToDoc head $+$ border '=' $+$ body $+$ return $ border '-' $+$ blockToDoc head $+$ border '=' $+$ body $+$
border '-' $$ caption'' $$ text "" border '-' $$ caption'' $$ text ""
blockToRST opts (BulletList items) = do blockToRST (BulletList items) = do
contents <- mapM (bulletListItemToRST opts) items contents <- mapM bulletListItemToRST items
-- ensure that sublists have preceding blank line -- ensure that sublists have preceding blank line
return $ text "" $+$ vcat contents <> text "\n" return $ text "" $+$ vcat contents <> text "\n"
blockToRST opts (OrderedList (start, style, delim) items) = do blockToRST (OrderedList (start, style, delim) items) = do
let markers = if start == 1 && style == DefaultStyle && delim == DefaultDelim let markers = if start == 1 && style == DefaultStyle && delim == DefaultDelim
then take (length items) $ repeat "#." then take (length items) $ repeat "#."
else take (length items) $ orderedListMarkers else take (length items) $ orderedListMarkers
@ -213,112 +225,110 @@ blockToRST opts (OrderedList (start, style, delim) items) = do
let maxMarkerLength = maximum $ map length markers let maxMarkerLength = maximum $ map length markers
let markers' = map (\m -> let s = maxMarkerLength - length m let markers' = map (\m -> let s = maxMarkerLength - length m
in m ++ replicate s ' ') markers in m ++ replicate s ' ') markers
contents <- mapM (\(item, num) -> orderedListItemToRST opts item num) $ contents <- mapM (\(item, num) -> orderedListItemToRST item num) $
zip markers' items zip markers' items
-- ensure that sublists have preceding blank line -- ensure that sublists have preceding blank line
return $ text "" $+$ vcat contents <> text "\n" return $ text "" $+$ vcat contents <> text "\n"
blockToRST opts (DefinitionList items) = do blockToRST (DefinitionList items) = do
contents <- mapM (definitionListItemToRST opts) items contents <- mapM definitionListItemToRST items
return $ (vcat contents) <> text "\n" return $ (vcat contents) <> text "\n"
-- | Convert bullet list item (list of blocks) to RST. -- | Convert bullet list item (list of blocks) to RST.
bulletListItemToRST :: WriterOptions -> [Block] -> State WriterState Doc bulletListItemToRST :: [Block] -> State WriterState Doc
bulletListItemToRST opts items = do bulletListItemToRST items = do
contents <- blockListToRST opts items contents <- blockListToRST items
return $ hang (text "- ") 3 contents return $ hang (text "- ") 3 contents
-- | Convert ordered list item (a list of blocks) to RST. -- | Convert ordered list item (a list of blocks) to RST.
orderedListItemToRST :: WriterOptions -- ^ options orderedListItemToRST :: String -- ^ marker for list item
-> String -- ^ marker for list item -> [Block] -- ^ list item (list of blocks)
-> [Block] -- ^ list item (list of blocks) -> State WriterState Doc
-> State WriterState Doc orderedListItemToRST marker items = do
orderedListItemToRST opts marker items = do contents <- blockListToRST items
contents <- blockListToRST opts items
return $ hang (text marker) (length marker + 1) contents return $ hang (text marker) (length marker + 1) contents
-- | Convert defintion list item (label, list of blocks) to RST. -- | Convert defintion list item (label, list of blocks) to RST.
definitionListItemToRST :: WriterOptions -> ([Inline], [Block]) -> State WriterState Doc definitionListItemToRST :: ([Inline], [Block]) -> State WriterState Doc
definitionListItemToRST opts (label, items) = do definitionListItemToRST (label, items) = do
label <- inlineListToRST opts label label <- inlineListToRST label
contents <- blockListToRST opts items contents <- blockListToRST items
return $ label $+$ nest (writerTabStop opts) contents tabstop <- get >>= (return . writerTabStop . stOptions)
return $ label $+$ nest tabstop contents
-- | Convert list of Pandoc block elements to RST. -- | Convert list of Pandoc block elements to RST.
blockListToRST :: WriterOptions -- ^ Options blockListToRST :: [Block] -- ^ List of block elements
-> [Block] -- ^ List of block elements -> State WriterState Doc
-> State WriterState Doc blockListToRST blocks = mapM blockToRST blocks >>= return . vcat
blockListToRST opts blocks =
mapM (blockToRST opts) blocks >>= return . vcat
-- | Convert list of Pandoc inline elements to RST. -- | Convert list of Pandoc inline elements to RST.
inlineListToRST :: WriterOptions -> [Inline] -> State WriterState Doc inlineListToRST :: [Inline] -> State WriterState Doc
inlineListToRST opts lst = mapM (inlineToRST opts) lst >>= return . hcat inlineListToRST lst = mapM inlineToRST lst >>= return . hcat
-- | Convert Pandoc inline element to RST. -- | Convert Pandoc inline element to RST.
inlineToRST :: WriterOptions -> Inline -> State WriterState Doc inlineToRST :: Inline -> State WriterState Doc
inlineToRST opts (Emph lst) = do inlineToRST (Emph lst) = do
contents <- inlineListToRST opts lst contents <- inlineListToRST lst
return $ char '*' <> contents <> char '*' return $ char '*' <> contents <> char '*'
inlineToRST opts (Strong lst) = do inlineToRST (Strong lst) = do
contents <- inlineListToRST opts lst contents <- inlineListToRST lst
return $ text "**" <> contents <> text "**" return $ text "**" <> contents <> text "**"
inlineToRST opts (Strikeout lst) = do inlineToRST (Strikeout lst) = do
contents <- inlineListToRST opts lst contents <- inlineListToRST lst
return $ text "[STRIKEOUT:" <> contents <> char ']' return $ text "[STRIKEOUT:" <> contents <> char ']'
inlineToRST opts (Superscript lst) = do inlineToRST (Superscript lst) = do
contents <- inlineListToRST opts lst contents <- inlineListToRST lst
return $ text "\\ :sup:`" <> contents <> text "`\\ " return $ text "\\ :sup:`" <> contents <> text "`\\ "
inlineToRST opts (Subscript lst) = do inlineToRST (Subscript lst) = do
contents <- inlineListToRST opts lst contents <- inlineListToRST lst
return $ text "\\ :sub:`" <> contents <> text "`\\ " return $ text "\\ :sub:`" <> contents <> text "`\\ "
inlineToRST opts (Quoted SingleQuote lst) = do inlineToRST (Quoted SingleQuote lst) = do
contents <- inlineListToRST opts lst contents <- inlineListToRST lst
return $ char '\'' <> contents <> char '\'' return $ char '\'' <> contents <> char '\''
inlineToRST opts (Quoted DoubleQuote lst) = do inlineToRST (Quoted DoubleQuote lst) = do
contents <- inlineListToRST opts lst contents <- inlineListToRST lst
return $ char '"' <> contents <> char '"' return $ char '"' <> contents <> char '"'
inlineToRST opts EmDash = return $ text "--" inlineToRST EmDash = return $ text "--"
inlineToRST opts EnDash = return $ char '-' inlineToRST EnDash = return $ char '-'
inlineToRST opts Apostrophe = return $ char '\'' inlineToRST Apostrophe = return $ char '\''
inlineToRST opts Ellipses = return $ text "..." inlineToRST Ellipses = return $ text "..."
inlineToRST opts (Code str) = return $ text $ "``" ++ str ++ "``" inlineToRST (Code str) = return $ text $ "``" ++ str ++ "``"
inlineToRST opts (Str str) = return $ text $ escapeString str inlineToRST (Str str) = return $ text $ escapeString str
inlineToRST opts (Math str) = return $ text $ "$" ++ str ++ "$" inlineToRST (Math str) = return $ text $ "$" ++ str ++ "$"
inlineToRST opts (TeX str) = return empty inlineToRST (TeX str) = return empty
inlineToRST opts (HtmlInline str) = return empty inlineToRST (HtmlInline str) = return empty
inlineToRST opts (LineBreak) = return $ char ' ' -- RST doesn't have linebreaks inlineToRST (LineBreak) = return $ char ' ' -- RST doesn't have linebreaks
inlineToRST opts Space = return $ char ' ' inlineToRST Space = return $ char ' '
inlineToRST opts (Link [Code str] (src, tit)) | src == str || inlineToRST (Link [Code str] (src, tit)) | src == str ||
src == "mailto:" ++ str = do src == "mailto:" ++ str = do
let srcSuffix = if isPrefixOf "mailto:" src then drop 7 src else src let srcSuffix = if isPrefixOf "mailto:" src then drop 7 src else src
return $ text srcSuffix return $ text srcSuffix
inlineToRST opts (Link txt (src, tit)) = do inlineToRST (Link txt (src, tit)) = do
let useReferenceLinks = writerReferenceLinks opts useReferenceLinks <- get >>= (return . writerReferenceLinks . stOptions)
linktext <- inlineListToRST opts $ normalizeSpaces txt linktext <- inlineListToRST $ normalizeSpaces txt
if useReferenceLinks if useReferenceLinks
then do (notes, refs, pics) <- get then do refs <- get >>= (return . stLinks)
let refs' = if (txt, (src, tit)) `elem` refs let refs' = if (txt, (src, tit)) `elem` refs
then refs then refs
else (txt, (src, tit)):refs else (txt, (src, tit)):refs
put (notes, refs', pics) modify $ \st -> st { stLinks = refs' }
return $ char '`' <> linktext <> text "`_" return $ char '`' <> linktext <> text "`_"
else return $ char '`' <> linktext <> text " <" <> text src <> text ">`_" else return $ char '`' <> linktext <> text " <" <> text src <> text ">`_"
inlineToRST opts (Image alternate (source, tit)) = do inlineToRST (Image alternate (source, tit)) = do
(notes, refs, pics) <- get pics <- get >>= (return . stImages)
let labelsUsed = map fst pics let labelsUsed = map fst pics
let txt = if null alternate || alternate == [Str ""] || let txt = if null alternate || alternate == [Str ""] ||
alternate `elem` labelsUsed alternate `elem` labelsUsed
then [Str $ "image" ++ show (length refs)] then [Str $ "image" ++ show (length pics)]
else alternate else alternate
let pics' = if (txt, (source, tit)) `elem` pics let pics' = if (txt, (source, tit)) `elem` pics
then pics then pics
else (txt, (source, tit)):pics else (txt, (source, tit)):pics
put (notes, refs, pics') modify $ \st -> st { stImages = pics' }
label <- inlineListToRST opts txt label <- inlineListToRST txt
return $ char '|' <> label <> char '|' return $ char '|' <> label <> char '|'
inlineToRST opts (Note contents) = do inlineToRST (Note contents) = do
-- add to notes in state -- add to notes in state
modify (\(notes, refs, pics) -> (contents:notes, refs, pics)) notes <- get >>= (return . stNotes)
(notes, _, _) <- get modify $ \st -> st { stNotes = contents:notes }
let ref = show $ (length notes) let ref = show $ (length notes) + 1
return $ text " [" <> text ref <> text "]_" return $ text " [" <> text ref <> text "]_"