diff options
Diffstat (limited to 'src/Text/Pandoc/Writers/Textile.hs')
| -rw-r--r-- | src/Text/Pandoc/Writers/Textile.hs | 486 |
1 files changed, 0 insertions, 486 deletions
diff --git a/src/Text/Pandoc/Writers/Textile.hs b/src/Text/Pandoc/Writers/Textile.hs deleted file mode 100644 index 45f1780cf..000000000 --- a/src/Text/Pandoc/Writers/Textile.hs +++ /dev/null @@ -1,486 +0,0 @@ -{- -Copyright (C) 2010-2015 John MacFarlane <jgm@berkeley.edu> - -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 <jgm@berkeley.edu> - Stability : alpha - Portability : portable - -Conversion of 'Pandoc' documents to Textile markup. - -Textile: <http://thresholdstate.com/articles/4312/the-textile-reference-manual> --} -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 <- liftM (unlines . reverse . stNotes) get - 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 <- 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 - '&' -> "&" - '<' -> "<" - '>' -> ">" - '"' -> """ - '*' -> "*" - '_' -> "_" - '@' -> "@" - '+' -> "+" - '-' -> "-" - '|' -> "|" - '\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 = "</div>" - 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 <- liftM stUseTags get - listLevel <- liftM stListLevel get - contents <- inlineListToTextile opts inlines - return $ if useTags - then "<p>" ++ contents ++ "</p>" - 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 "<hr />\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 $ "<pre" ++ classes' ++ ">\n" ++ escapeStringForXML str ++ - "\n</pre>\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 $ "<blockquote>\n\n" ++ contents ++ "\n</blockquote>\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 $ "<caption>" ++ c ++ "</caption>\n" - let percent w = show (truncate (100*w) :: Integer) ++ "%" - let coltags = if all (== 0.0) widths - then "" - else unlines $ map - (\w -> "<col width=\"" ++ percent w ++ "\" />") widths - head' <- if all null headers - then return "" - else do - hs <- tableRowToTextile opts alignStrings 0 headers - return $ "<thead>\n" ++ hs ++ "\n</thead>\n" - body' <- zipWithM (tableRowToTextile opts alignStrings) [1..] rows' - return $ "<table>\n" ++ captionDoc ++ coltags ++ head' ++ - "<tbody>\n" ++ unlines body' ++ "</tbody>\n</table>\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 $ "<ul>\n" ++ vcat contents ++ "\n</ul>\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@(start, _, _) items) = do - oldUseTags <- liftM stUseTags get - let useTags = oldUseTags || not (isSimpleList x) - if useTags - then do - contents <- withUseTags $ mapM (listItemToTextile opts) items - return $ "<ol" ++ listAttribsToString attribs ++ ">\n" ++ vcat contents ++ - "\n</ol>\n" - else do - modify $ \s -> s { stListLevel = stListLevel s ++ "#" - , stStartNum = if start > 1 - then Just start - else Nothing } - level <- get >>= return . 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 $ "<dl>\n" ++ vcat contents ++ "\n</dl>\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 $ "<li>" ++ contents ++ "</li>" - 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 $ "<dt>" ++ labelText ++ "</dt>\n" ++ - (intercalate "\n" $ map (\d -> "<dd>" ++ d ++ "</dd>") 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 $ "<tr class=\"" ++ rowclass ++ "\">\n" ++ unlines cols'' ++ "</tr>" - -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 ++ "</" ++ celltype ++ ">" - 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 "<em>" ++ contents ++ "</em>" - else "_" ++ contents ++ "_" - -inlineToTextile opts (Strong lst) = do - contents <- inlineListToTextile opts lst - return $ if '*' `elem` contents - then "<strong>" ++ contents ++ "</strong>" - else "*" ++ contents ++ "*" - -inlineToTextile opts (Strikeout lst) = do - contents <- inlineListToTextile opts lst - return $ if '-' `elem` contents - then "<del>" ++ contents ++ "</del>" - else "-" ++ contents ++ "-" - -inlineToTextile opts (Superscript lst) = do - contents <- inlineListToTextile opts lst - return $ if '^' `elem` contents - then "<sup>" ++ contents ++ "</sup>" - else "[^" ++ contents ++ "^]" - -inlineToTextile opts (Subscript lst) = do - contents <- inlineListToTextile opts lst - return $ if '~' `elem` contents - then "<sub>" ++ contents ++ "</sub>" - 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 "<tt>" ++ escapeStringForXML str ++ "</tt>" - else "@" ++ str ++ "@" - -inlineToTextile _ (Str str) = return $ escapeStringForTextile str - -inlineToTextile _ (Math _ str) = - return $ "<span class=\"math\">" ++ escapeStringForXML str ++ "</math>" - -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 <- 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 |