From d073b168924a8391c771ecf47af3448bdfa027c6 Mon Sep 17 00:00:00 2001 From: John MacFarlane Date: Sat, 10 Apr 2010 12:38:07 -0700 Subject: Added Textile writer module. --- src/Text/Pandoc.hs | 2 + src/Text/Pandoc/Writers/Textile.hs | 413 +++++++++++++++++++++++++++++++++++++ 2 files changed, 415 insertions(+) create mode 100644 src/Text/Pandoc/Writers/Textile.hs (limited to 'src/Text') diff --git a/src/Text/Pandoc.hs b/src/Text/Pandoc.hs index 9cad5fb34..b3a7fddbc 100644 --- a/src/Text/Pandoc.hs +++ b/src/Text/Pandoc.hs @@ -85,6 +85,7 @@ module Text.Pandoc , writeOpenDocument , writeMan , writeMediaWiki + , writeTextile , writeRTF , prettyPandoc -- * Writer options used in writers @@ -114,6 +115,7 @@ import Text.Pandoc.Writers.OpenDocument import Text.Pandoc.Writers.Man import Text.Pandoc.Writers.RTF import Text.Pandoc.Writers.MediaWiki +import Text.Pandoc.Writers.Textile import Text.Pandoc.Templates import Text.Pandoc.Shared import Data.Version (showVersion) diff --git a/src/Text/Pandoc/Writers/Textile.hs b/src/Text/Pandoc/Writers/Textile.hs new file mode 100644 index 000000000..8dd2288c9 --- /dev/null +++ b/src/Text/Pandoc/Writers/Textile.hs @@ -0,0 +1,413 @@ +{- +Copyright (C) 2010 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.Textile + Copyright : Copyright (C) 2010 John MacFarlane + License : GNU GPL, version 2 or above + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Conversion of 'Pandoc' documents to Textile markup. + +Textile: +-} +module Text.Pandoc.Writers.Textile ( writeTextile ) where +import Text.Pandoc.Definition +import Text.Pandoc.Shared +import Text.Pandoc.Templates (renderTemplate) +import Text.Pandoc.XML ( escapeStringForXML ) +import Data.List ( intercalate ) +import Control.Monad.State +import Data.Char ( isSpace ) + +data WriterState = WriterState { + stNotes :: [String] -- Footnotes + , stListLevel :: [Char] -- String at beginning of list items, e.g. "**" + , stUseTags :: Bool -- True if we should use HTML tags because we're in a complex list + } + +-- | Convert Pandoc to Textile. +writeTextile :: WriterOptions -> Pandoc -> String +writeTextile opts document = + evalState (pandocToTextile opts document) + (WriterState { stNotes = [], stListLevel = [], stUseTags = False }) + +-- | Return Textile representation of document. +pandocToTextile :: WriterOptions -> Pandoc -> State WriterState String +pandocToTextile opts (Pandoc _ blocks) = do + body <- blockListToTextile opts blocks + notes <- liftM (unlines . reverse . stNotes) get + let main = body ++ if null notes then "" else ("\n\n" ++ notes) + let context = writerVariables opts ++ [ ("body", main) ] + if writerStandalone opts + then return $ renderTemplate context $ writerTemplate opts + else return main + +withUseTags :: State WriterState a -> State WriterState a +withUseTags action = do + oldUseTags <- liftM stUseTags get + modify $ \s -> s { stUseTags = True } + result <- action + modify $ \s -> s { stUseTags = oldUseTags } + return result + +-- | Escape one character as needed for Textile. +escapeCharForTextile :: Char -> String +escapeCharForTextile x = case x of + '&' -> "&" + '<' -> "<" + '>' -> ">" + '"' -> """ + '*' -> "*" + '_' -> "_" + '@' -> "@" + '|' -> "|" + c -> [c] + +-- | Escape string as needed for Textile. +escapeStringForTextile :: String -> String +escapeStringForTextile = concatMap escapeCharForTextile + +-- | Convert Pandoc block element to Textile. +blockToTextile :: WriterOptions -- ^ Options + -> Block -- ^ Block element + -> State WriterState String + +blockToTextile _ Null = return "" + +blockToTextile opts (Plain inlines) = + inlineListToTextile opts inlines + +blockToTextile opts (Para [Image txt (src,tit)]) = do + capt <- blockToTextile opts (Para txt) + im <- inlineToTextile opts (Image txt (src,tit)) + return $ im ++ "\n" ++ capt + +blockToTextile opts (Para inlines) = do + useTags <- liftM stUseTags get + listLevel <- liftM stListLevel get + contents <- inlineListToTextile opts inlines + return $ if useTags + then "

" ++ contents ++ "

" + else contents ++ if null listLevel then "\n" else "" + +blockToTextile _ (RawHtml str) = return str + +blockToTextile _ HorizontalRule = return "
\n" + +blockToTextile opts (Header level inlines) = do + contents <- inlineListToTextile opts inlines + let prefix = 'h' : (show level ++ ". ") + return $ prefix ++ contents ++ "\n" + +blockToTextile _ (CodeBlock (_,classes,_) str) = + return $ "bc" ++ classes' ++ dots ++ escapeStringForXML str ++ "\n" + where classes' = if null classes + then "" + else "(" ++ unwords classes ++ ")" + dots = if any isBlank (lines str) + then ".. " + else ". " + isBlank = all isSpace + +blockToTextile opts (BlockQuote bs@[Para _]) = do + contents <- blockListToTextile opts bs + return $ "bq. " ++ contents + +blockToTextile opts (BlockQuote blocks) = do + contents <- blockListToTextile opts blocks + return $ "
\n\n" ++ contents ++ "\n
\n" + +blockToTextile opts (Table [] aligns widths headers rows') | + all (==0) widths && all (`elem` [AlignLeft,AlignDefault]) aligns = do + hs <- mapM (liftM (("_. " ++) . stripTrailingNewlines) . blockListToTextile opts) headers + let cellsToRow cells = "|" ++ intercalate "|" cells ++ "|" + let header = if all null headers then "" else cellsToRow hs + let rowToCells = mapM (liftM stripTrailingNewlines . blockListToTextile opts) + bs <- mapM rowToCells rows' + let body = unlines $ map cellsToRow bs + return $ header ++ "\n" ++ body ++ "\n" + +blockToTextile opts (Table capt aligns widths headers rows') = do + let alignStrings = map alignmentToString aligns + captionDoc <- if null capt + then return "" + else do + c <- inlineListToTextile opts capt + return $ " " ++ c ++ "\n" + let percent w = show (truncate (100*w) :: Integer) ++ "%" + let coltags = if all (== 0.0) widths + then "" + else unlines $ map + (\w -> " ") widths + head' <- if all null headers + then return "" + else do + hs <- tableRowToTextile opts alignStrings 0 headers + return $ " \n" ++ hs ++ "\n \n" + body' <- zipWithM (tableRowToTextile opts alignStrings) [1..] rows' + return $ " \n" ++ captionDoc ++ coltags ++ head' ++ + " \n" ++ unlines body' ++ " \n
\n" + +blockToTextile opts x@(BulletList items) = do + oldUseTags <- liftM stUseTags get + let useTags = oldUseTags || not (isSimpleList x) + if useTags + then do + contents <- withUseTags $ mapM (listItemToTextile opts) items + return $ "
    \n" ++ vcat contents ++ "
\n" + else do + modify $ \s -> s { stListLevel = stListLevel s ++ "*" } + contents <- mapM (listItemToTextile opts) items + modify $ \s -> s { stListLevel = init (stListLevel s) } + return $ vcat contents ++ "\n" + +blockToTextile opts x@(OrderedList attribs items) = do + oldUseTags <- liftM stUseTags get + let useTags = oldUseTags || not (isSimpleList x) + if useTags + then do + contents <- withUseTags $ mapM (listItemToTextile opts) items + return $ " \n" ++ vcat contents ++ + " \n" + else do + modify $ \s -> s { stListLevel = stListLevel s ++ "#" } + contents <- mapM (listItemToTextile opts) items + modify $ \s -> s { stListLevel = init (stListLevel s) } + return $ vcat contents ++ "\n" + +blockToTextile opts (DefinitionList items) = do + contents <- withUseTags $ mapM (definitionListItemToTextile opts) items + return $ "
\n" ++ vcat contents ++ "
\n" + +-- Auxiliary functions for lists: + +-- | Convert ordered list attributes to HTML attribute string +listAttribsToString :: ListAttributes -> String +listAttribsToString (startnum, numstyle, _) = + let numstyle' = camelCaseToHyphenated $ show numstyle + in (if startnum /= 1 + then " start=\"" ++ show startnum ++ "\"" + else "") ++ + (if numstyle /= DefaultStyle + then " style=\"list-style-type: " ++ numstyle' ++ ";\"" + else "") + +-- | Convert bullet or ordered list item (list of blocks) to Textile. +listItemToTextile :: WriterOptions -> [Block] -> State WriterState String +listItemToTextile opts items = do + contents <- blockListToTextile opts items + useTags <- get >>= return . stUseTags + if useTags + then return $ "
  • " ++ contents ++ "
    • " + else do + marker <- get >>= return . stListLevel + return $ marker ++ " " ++ contents + +-- | Convert definition list item (label, list of blocks) to Textile. +definitionListItemToTextile :: WriterOptions + -> ([Inline],[[Block]]) + -> State WriterState String +definitionListItemToTextile opts (label, items) = do + labelText <- inlineListToTextile opts label + contents <- mapM (blockListToTextile opts) items + return $ "
    " ++ labelText ++ "
    \n" ++ + (intercalate "\n" $ map (\d -> "
    " ++ d ++ "
    ") contents) + +-- | True if the list can be handled by simple wiki markup, False if HTML tags will be needed. +isSimpleList :: Block -> Bool +isSimpleList x = + case x of + BulletList items -> all isSimpleListItem items + OrderedList (num, sty, _) items -> all isSimpleListItem items && + num == 1 && sty `elem` [DefaultStyle, Decimal] + _ -> False + +-- | True if list item can be handled with the simple wiki syntax. False if +-- HTML tags will be needed. +isSimpleListItem :: [Block] -> Bool +isSimpleListItem [] = True +isSimpleListItem [x] = + case x of + Plain _ -> True + Para _ -> True + BulletList _ -> isSimpleList x + OrderedList _ _ -> isSimpleList x + _ -> False +isSimpleListItem [x, y] | isPlainOrPara x = + case y of + BulletList _ -> isSimpleList y + OrderedList _ _ -> isSimpleList y + _ -> False +isSimpleListItem _ = False + +isPlainOrPara :: Block -> Bool +isPlainOrPara (Plain _) = True +isPlainOrPara (Para _) = True +isPlainOrPara _ = False + +-- | Concatenates strings with line breaks between them. +vcat :: [String] -> String +vcat = intercalate "\n" + +-- Auxiliary functions for tables. (TODO: these are common to HTML, MediaWiki, +-- and Textile writers, and should be abstracted out.) + +tableRowToTextile :: WriterOptions + -> [String] + -> Int + -> [[Block]] + -> State WriterState String +tableRowToTextile opts alignStrings rownum cols' = do + let celltype = if rownum == 0 then "th" else "td" + let rowclass = case rownum of + 0 -> "header" + x | x `rem` 2 == 1 -> "odd" + _ -> "even" + cols'' <- sequence $ zipWith + (\alignment item -> tableItemToTextile opts celltype alignment item) + alignStrings cols' + return $ "\n" ++ unlines cols'' ++ "" + +alignmentToString :: Alignment -> [Char] +alignmentToString alignment = case alignment of + AlignLeft -> "left" + AlignRight -> "right" + AlignCenter -> "center" + AlignDefault -> "left" + +tableItemToTextile :: WriterOptions + -> String + -> String + -> [Block] + -> State WriterState String +tableItemToTextile opts celltype align' item = do + let mkcell x = "<" ++ celltype ++ " align=\"" ++ align' ++ "\">" ++ + x ++ "" + contents <- blockListToTextile opts item + return $ mkcell contents + +-- | Convert list of Pandoc block elements to Textile. +blockListToTextile :: WriterOptions -- ^ Options + -> [Block] -- ^ List of block elements + -> State WriterState String +blockListToTextile opts blocks = + mapM (blockToTextile opts) blocks >>= return . vcat + +-- | Convert list of Pandoc inline elements to Textile. +inlineListToTextile :: WriterOptions -> [Inline] -> State WriterState String +inlineListToTextile opts lst = + mapM (inlineToTextile opts) lst >>= return . concat + +-- | Convert Pandoc inline element to Textile. +inlineToTextile :: WriterOptions -> Inline -> State WriterState String + +inlineToTextile opts (Emph lst) = do + contents <- inlineListToTextile opts lst + return $ if '_' `elem` contents + then "" ++ contents ++ "" + else "_" ++ contents ++ "_" + +inlineToTextile opts (Strong lst) = do + contents <- inlineListToTextile opts lst + return $ if '*' `elem` contents + then "" ++ contents ++ "" + else "*" ++ contents ++ "*" + +inlineToTextile opts (Strikeout lst) = do + contents <- inlineListToTextile opts lst + return $ if '-' `elem` contents + then "" ++ contents ++ "" + else "-" ++ contents ++ "-" + +inlineToTextile opts (Superscript lst) = do + contents <- inlineListToTextile opts lst + return $ if '^' `elem` contents + then "" ++ contents ++ "" + else "^" ++ contents ++ "^" + +inlineToTextile opts (Subscript lst) = do + contents <- inlineListToTextile opts lst + return $ if '~' `elem` contents + then "" ++ contents ++ "" + else "~" ++ contents ++ "~" + +inlineToTextile opts (SmallCaps lst) = inlineListToTextile opts lst + +inlineToTextile opts (Quoted SingleQuote lst) = do + contents <- inlineListToTextile opts lst + return $ "'" ++ contents ++ "'" + +inlineToTextile opts (Quoted DoubleQuote lst) = do + contents <- inlineListToTextile opts lst + return $ "\"" ++ contents ++ "\"" + +inlineToTextile opts (Cite _ lst) = inlineListToTextile opts lst + +inlineToTextile _ EmDash = return " -- " + +inlineToTextile _ EnDash = return " - " + +inlineToTextile _ Apostrophe = return "'" + +inlineToTextile _ Ellipses = return "..." + +inlineToTextile _ (Code str) = + return $ if '@' `elem` str + then "" ++ escapeStringForXML str ++ "" + else "@" ++ escapeStringForXML str ++ "@" + +inlineToTextile _ (Str str) = return $ escapeStringForTextile str + +inlineToTextile _ (Math _ str) = + return $ "" ++ escapeStringForXML str ++ "" + +inlineToTextile _ (TeX _) = return "" + +inlineToTextile _ (HtmlInline str) = return str + +inlineToTextile _ (LineBreak) = return "\n" + +inlineToTextile _ Space = return " " + +inlineToTextile opts (Link txt (src, _)) = do + label <- case txt of + [Code s] -> return s + _ -> inlineListToTextile opts txt + return $ "\"" ++ label ++ "\":" ++ src + +inlineToTextile opts (Image alt (source, tit)) = do + alt' <- inlineListToTextile opts alt + let txt = if null tit + then if null alt' + then "" + else "(" ++ alt' ++ ")" + else "(" ++ tit ++ ")" + return $ "!" ++ source ++ txt ++ "!" + +inlineToTextile opts (Note contents) = do + curNotes <- liftM stNotes get + let newnum = length curNotes + 1 + contents' <- blockListToTextile opts contents + let thisnote = "fn" ++ show newnum ++ ". " ++ contents' ++ "\n" + modify $ \s -> s { stNotes = thisnote : curNotes } + return $ "[" ++ show newnum ++ "]" + -- note - may not work for notes with multiple blocks -- cgit v1.2.3