{- Copyright (C) 2010-2015 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-2015 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.Options import Text.Pandoc.Shared import Text.Pandoc.Pretty (render) import Text.Pandoc.ImageSize import Text.Pandoc.Writers.Shared import Text.Pandoc.Templates (renderTemplate') import Text.Pandoc.XML ( escapeStringForXML ) import Data.List ( intercalate ) import Control.Monad.State import Data.Char ( isSpace ) import Text.Pandoc.Class ( PandocMonad ) data WriterState = WriterState { stNotes :: [String] -- Footnotes , stListLevel :: [Char] -- String at beginning of list items, e.g. "**" , stStartNum :: Maybe Int -- Start number if first list item , stUseTags :: Bool -- True if we should use HTML tags because we're in a complex list } -- | Convert Pandoc to Textile. writeTextile :: PandocMonad m => WriterOptions -> Pandoc -> m String writeTextile opts document = return $ evalState (pandocToTextile opts document) WriterState { stNotes = [], stListLevel = [], stStartNum = Nothing, stUseTags = False } -- | Return Textile representation of document. pandocToTextile :: WriterOptions -> Pandoc -> State WriterState String pandocToTextile opts (Pandoc meta blocks) = do metadata <- metaToJSON opts (blockListToTextile opts) (inlineListToTextile opts) meta body <- blockListToTextile opts blocks notes <- gets $ unlines . reverse . stNotes let main = body ++ if null notes then "" else ("\n\n" ++ notes) let context = defField "body" main metadata case writerTemplate opts of Nothing -> return main Just tpl -> return $ renderTemplate' tpl context withUseTags :: State WriterState a -> State WriterState a withUseTags action = do oldUseTags <- gets stUseTags 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 '&' -> "&" '<' -> "<" '>' -> ">" '"' -> """ '*' -> "*" '_' -> "_" '@' -> "@" '+' -> "+" '-' -> "-" '|' -> "|" '\x2014' -> " -- " '\x2013' -> " - " '\x2019' -> "'" '\x2026' -> "..." 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 (Div attr bs) = do let startTag = render Nothing $ tagWithAttrs "div" attr let endTag = "" contents <- blockListToTextile opts bs return $ startTag ++ "\n\n" ++ contents ++ "\n\n" ++ endTag ++ "\n" blockToTextile opts (Plain inlines) = inlineListToTextile opts inlines -- title beginning with fig: indicates that the image is a figure blockToTextile opts (Para [Image attr txt (src,'f':'i':'g':':':tit)]) = do capt <- blockToTextile opts (Para txt) im <- inlineToTextile opts (Image attr txt (src,tit)) return $ im ++ "\n" ++ capt blockToTextile opts (Para inlines) = do useTags <- gets stUseTags listLevel <- gets stListLevel contents <- inlineListToTextile opts inlines return $ if useTags then "

" ++ contents ++ "

" else contents ++ if null listLevel then "\n" else "" blockToTextile opts (LineBlock lns) = blockToTextile opts $ linesToPara lns blockToTextile _ (RawBlock f str) | f == Format "html" || f == Format "textile" = return str | otherwise = return "" blockToTextile _ HorizontalRule = return "
\n" blockToTextile opts (Header level (ident,classes,keyvals) inlines) = do contents <- inlineListToTextile opts inlines let identAttr = if null ident then "" else ('#':ident) let attribs = if null identAttr && null classes then "" else "(" ++ unwords classes ++ identAttr ++ ")" let lang = maybe "" (\x -> "[" ++ x ++ "]") $ lookup "lang" keyvals let styles = maybe "" (\x -> "{" ++ x ++ "}") $ lookup "style" keyvals let prefix = 'h' : show level ++ attribs ++ styles ++ lang ++ ". " 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' ++ ". " ++ str ++ "\n\n" where classes' = if null classes then "" else "(" ++ unwords classes ++ ")" blockToTextile opts (BlockQuote bs@[Para _]) = do contents <- blockListToTextile opts bs return $ "bq. " ++ contents ++ "\n\n" 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 = do hs <- mapM (liftM (("_. " ++) . stripTrailingNewlines) . blockListToTextile opts) headers let cellsToRow cells = "|" ++ intercalate "|" cells ++ "|" let header = if all null headers then "" else cellsToRow hs ++ "\n" let blocksToCell (align, bs) = do contents <- stripTrailingNewlines <$> blockListToTextile opts bs let alignMarker = case align of AlignLeft -> "<. " AlignRight -> ">. " AlignCenter -> "=. " AlignDefault -> "" return $ alignMarker ++ contents let rowToCells = mapM blocksToCell . zip aligns bs <- mapM rowToCells rows' let body = unlines $ map cellsToRow bs return $ header ++ body 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 <- gets stUseTags let useTags = oldUseTags || not (isSimpleList x) if useTags then do contents <- withUseTags $ mapM (listItemToTextile opts) items return $ "
    \n" ++ vcat contents ++ "\n
\n" else do modify $ \s -> s { stListLevel = stListLevel s ++ "*" } level <- gets $ 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@(start, _, _) items) = do oldUseTags <- gets stUseTags let useTags = oldUseTags || not (isSimpleList x) if useTags then do contents <- withUseTags $ mapM (listItemToTextile opts) items return $ "\n" ++ vcat contents ++ "\n\n" else do modify $ \s -> s { stListLevel = stListLevel s ++ "#" , stStartNum = if start > 1 then Just start else Nothing } level <- gets $ length . stListLevel contents <- mapM (listItemToTextile opts) items modify $ \s -> s { stListLevel = init (stListLevel s), stStartNum = Nothing } 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
\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 <- gets stUseTags if useTags then return $ "
  • " ++ contents ++ "
    • " else do marker <- gets stListLevel mbstart <- gets stStartNum case mbstart of Just n -> do modify $ \s -> s{ stStartNum = Nothing } return $ marker ++ show n ++ " " ++ contents Nothing -> 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 (_, sty, _) items -> all isSimpleListItem items && 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 (Span _ lst) = inlineListToTextile opts lst 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 _ (Code _ str) = return $ if '@' `elem` str then "" ++ escapeStringForXML str ++ "" else "@" ++ str ++ "@" inlineToTextile _ (Str str) = return $ escapeStringForTextile str inlineToTextile _ (Math _ str) = return $ "" ++ escapeStringForXML str ++ "" inlineToTextile opts (RawInline f str) | f == Format "html" || f == Format "textile" = return str | (f == Format "latex" || f == Format "tex") && isEnabled Ext_raw_tex opts = return str | otherwise = return "" inlineToTextile _ LineBreak = return "\n" inlineToTextile _ SoftBreak = return " " inlineToTextile _ Space = return " " inlineToTextile opts (Link (_, cls, _) txt (src, _)) = do let classes = if null cls then "" else "(" ++ unwords cls ++ ")" label <- case txt of [Code _ s] | s == src -> return "$" [Str s] | s == src -> return "$" _ -> inlineListToTextile opts txt return $ "\"" ++ classes ++ label ++ "\":" ++ src inlineToTextile opts (Image attr@(_, cls, _) alt (source, tit)) = do alt' <- inlineListToTextile opts alt let txt = if null tit then if null alt' then "" else "(" ++ alt' ++ ")" else "(" ++ tit ++ ")" classes = if null cls then "" else "(" ++ unwords cls ++ ")" showDim dir = let toCss str = Just $ show dir ++ ":" ++ str ++ ";" in case (dimension dir attr) of Just (Percent a) -> toCss $ show (Percent a) Just dim -> toCss $ showInPixel opts dim ++ "px" Nothing -> Nothing styles = case (showDim Width, showDim Height) of (Just w, Just h) -> "{" ++ w ++ h ++ "}" (Just w, Nothing) -> "{" ++ w ++ "height:auto;}" (Nothing, Just h) -> "{" ++ "width:auto;" ++ h ++ "}" (Nothing, Nothing) -> "" return $ "!" ++ classes ++ styles ++ source ++ txt ++ "!" inlineToTextile opts (Note contents) = do curNotes <- gets stNotes 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