{- Copyright (C) 2006-7 John MacFarlane 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 Stability : alpha Portability : portable Conversion of 'Pandoc' documents to reStructuredText. reStructuredText: -} 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 "]_"