{- 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) | any (all isSpace) (lines str) = return $ "\n" ++ escapeStringForXML str ++ "\n\n" where classes' = if null classes then "" else " class=\"" ++ unwords classes ++ "\"" blockToTextile _ (CodeBlock (_,classes,_) str) = return $ "bc" ++ classes' ++ ". " ++ escapeStringForXML str ++ "\n" where classes' = if null classes then "" else "(" ++ unwords classes ++ ")" 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 ++ "*" } level <- get >>= return . length . stListLevel contents <- mapM (listItemToTextile opts) items modify $ \s -> s { stListLevel = init (stListLevel s) } return $ vcat contents ++ (if level > 1 then "" else "\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 ++ "#" } level <- get >>= return . length . stListLevel contents <- mapM (listItemToTextile opts) items modify $ \s -> s { stListLevel = init (stListLevel s) } return $ vcat contents ++ (if level > 1 then "" else "\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