Added Textile writer module.

2 files changed, 415 insertions, 0 deletions

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 <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 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.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
+                         '&'    -> "&amp;"
+                         '<'    -> "&lt;"
+                         '>'    -> "&gt;"
+                         '"'    -> "&quot;"
+                         '*'    -> "&#42;"
+                         '_'    -> "&#95;"
+                         '@'    -> "&#64;"
+                         '|'    -> "&#124;"
+                         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 " <p>" ++ contents ++ "</p>"
+              else contents ++ if null listLevel then "\n" else ""
+
+blockToTextile _ (RawHtml str) = return str
+
+blockToTextile _ HorizontalRule = return "<hr />\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 $ "<blockquote>\n\n" ++ contents ++ "\n</blockquote>\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 $ " <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 ++ " </ul>\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 $ " <ol" ++ listAttribsToString attribs ++ ">\n" ++ vcat contents ++
+                   " </ol>\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 $ " <dl>\n" ++ vcat contents ++ " </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 <- 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 $ " <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 (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 $ "<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 (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 _ EmDash = return " -- "
+
+inlineToTextile _ EnDash = return " - "
+
+inlineToTextile _ Apostrophe = return "'"
+
+inlineToTextile _ Ellipses = return "..."
+
+inlineToTextile _ (Code str) =
+  return $ if '@' `elem` str
+           then "<tt>" ++ escapeStringForXML str ++ "</tt>"
+           else "@" ++ escapeStringForXML str ++ "@" 
+
+inlineToTextile _ (Str str) = return $ escapeStringForTextile str
+
+inlineToTextile _ (Math _ str) =
+  return $ "<span class=\"math\">" ++ escapeStringForXML str ++ "</math>"
+
+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