module Text.Pandoc.Writers.RTF ( writeRTF, rtfEmbedImage ) where
import Text.Pandoc.Definition
import Text.Pandoc.Shared
import Text.Pandoc.Readers.TeXMath
import Text.Pandoc.Templates (renderTemplate)
import Data.List ( isSuffixOf, intercalate )
import Data.Char ( ord, isDigit, toLower )
import System.FilePath ( takeExtension )
import qualified Data.ByteString as B
import Text.Printf ( printf )
rtfEmbedImage :: Inline -> IO Inline
rtfEmbedImage x@(Image _ (src,_))
| map toLower (takeExtension src) `elem` [".jpg",".jpeg",".png"] = do
imgdata <- catch (B.readFile src) (\_ -> return B.empty)
let bytes = map (printf "%02x") $ B.unpack imgdata
let filetype = case map toLower (takeExtension src) of
".jpg" -> "\\jpegblip"
".jpeg" -> "\\jpegblip"
".png" -> "\\pngblip"
_ -> error "Unknown file type"
let raw = "{\\pict" ++ filetype ++ " " ++ concat bytes ++ "}"
return $ if B.null imgdata
then x
else RawInline "rtf" raw
rtfEmbedImage x = return x
writeRTF :: WriterOptions -> Pandoc -> String
writeRTF options (Pandoc (Meta title authors date) blocks) =
let titletext = inlineListToRTF title
authorstext = map inlineListToRTF authors
datetext = inlineListToRTF date
spacer = not $ all null $ titletext : datetext : authorstext
body = concatMap (blockToRTF 0 AlignDefault) blocks
context = writerVariables options ++
[ ("body", body)
, ("title", titletext)
, ("date", datetext) ] ++
[ ("author", a) | a <- authorstext ] ++
[ ("spacer", "yes") | spacer ] ++
[ ("toc", tableOfContents $ filter isHeaderBlock blocks) |
writerTableOfContents options ]
in if writerStandalone options
then renderTemplate context $ writerTemplate options
else body
tableOfContents :: [Block] -> String
tableOfContents headers =
let contentsTree = hierarchicalize headers
in concatMap (blockToRTF 0 AlignDefault) $
[Header 1 [Str "Contents"],
BulletList (map elementToListItem contentsTree)]
elementToListItem :: Element -> [Block]
elementToListItem (Blk _) = []
elementToListItem (Sec _ _ _ sectext subsecs) = [Plain sectext] ++
if null subsecs
then []
else [BulletList (map elementToListItem subsecs)]
handleUnicode :: String -> String
handleUnicode [] = []
handleUnicode (c:cs) =
if ord c > 127
then '\\':'u':(show (ord c)) ++ "?" ++ handleUnicode cs
else c:(handleUnicode cs)
escapeSpecial :: String -> String
escapeSpecial = escapeStringUsing (('\t',"\\tab "):(backslashEscapes "{\\}"))
stringToRTF :: String -> String
stringToRTF = handleUnicode . escapeSpecial
codeStringToRTF :: String -> String
codeStringToRTF str = intercalate "\\line\n" $ lines (stringToRTF str)
rtfParSpaced :: Int
-> Int
-> Int
-> Alignment
-> String
-> String
rtfParSpaced spaceAfter indent firstLineIndent alignment content =
let alignString = case alignment of
AlignLeft -> "\\ql "
AlignRight -> "\\qr "
AlignCenter -> "\\qc "
AlignDefault -> "\\ql "
in "{\\pard " ++ alignString ++
"\\f0 \\sa" ++ (show spaceAfter) ++ " \\li" ++ (show indent) ++
" \\fi" ++ (show firstLineIndent) ++ " " ++ content ++ "\\par}\n"
rtfPar :: Int
-> Int
-> Alignment
-> String
-> String
rtfPar = rtfParSpaced 180
rtfCompact :: Int
-> Int
-> Alignment
-> String
-> String
rtfCompact = rtfParSpaced 0
indentIncrement :: Int
indentIncrement = 720
listIncrement :: Int
listIncrement = 360
bulletMarker :: Int -> String
bulletMarker indent = case indent `mod` 720 of
0 -> "\\bullet "
_ -> "\\endash "
orderedMarkers :: Int -> ListAttributes -> [String]
orderedMarkers indent (start, style, delim) =
if style == DefaultStyle && delim == DefaultDelim
then case indent `mod` 720 of
0 -> orderedListMarkers (start, Decimal, Period)
_ -> orderedListMarkers (start, LowerAlpha, Period)
else orderedListMarkers (start, style, delim)
blockToRTF :: Int
-> Alignment
-> Block
-> String
blockToRTF _ _ Null = ""
blockToRTF indent alignment (Plain lst) =
rtfCompact indent 0 alignment $ inlineListToRTF lst
blockToRTF indent alignment (Para lst) =
rtfPar indent 0 alignment $ inlineListToRTF lst
blockToRTF indent alignment (BlockQuote lst) =
concatMap (blockToRTF (indent + indentIncrement) alignment) lst
blockToRTF indent _ (CodeBlock _ str) =
rtfPar indent 0 AlignLeft ("\\f1 " ++ (codeStringToRTF str))
blockToRTF _ _ (RawBlock "rtf" str) = str
blockToRTF _ _ (RawBlock _ _) = ""
blockToRTF indent alignment (BulletList lst) = spaceAtEnd $
concatMap (listItemToRTF alignment indent (bulletMarker indent)) lst
blockToRTF indent alignment (OrderedList attribs lst) = spaceAtEnd $ concat $
zipWith (listItemToRTF alignment indent) (orderedMarkers indent attribs) lst
blockToRTF indent alignment (DefinitionList lst) = spaceAtEnd $
concatMap (definitionListItemToRTF alignment indent) lst
blockToRTF indent _ HorizontalRule =
rtfPar indent 0 AlignCenter "\\emdash\\emdash\\emdash\\emdash\\emdash"
blockToRTF indent alignment (Header level lst) = rtfPar indent 0 alignment $
"\\b \\fs" ++ (show (40 (level * 4))) ++ " " ++ inlineListToRTF lst
blockToRTF indent alignment (Table caption aligns sizes headers rows) =
(if all null headers
then ""
else tableRowToRTF True indent aligns sizes headers) ++
concatMap (tableRowToRTF False indent aligns sizes) rows ++
rtfPar indent 0 alignment (inlineListToRTF caption)
tableRowToRTF :: Bool -> Int -> [Alignment] -> [Double] -> [[Block]] -> String
tableRowToRTF header indent aligns sizes' cols =
let totalTwips = 6 * 1440
sizes = if all (== 0) sizes'
then take (length cols) $ repeat (1.0 / fromIntegral (length cols))
else sizes'
columns = concat $ zipWith (tableItemToRTF indent) aligns cols
rightEdges = tail $ scanl (\sofar new -> sofar + floor (new * totalTwips))
(0 :: Integer) sizes
cellDefs = map (\edge -> (if header
then "\\clbrdrb\\brdrs"
else "") ++ "\\cellx" ++ show edge)
rightEdges
start = "{\n\\trowd \\trgaph120\n" ++ concat cellDefs ++ "\n" ++
"\\trkeep\\intbl\n{\n"
end = "}\n\\intbl\\row}\n"
in start ++ columns ++ end
tableItemToRTF :: Int -> Alignment -> [Block] -> String
tableItemToRTF indent alignment item =
let contents = concatMap (blockToRTF indent alignment) item
in "{\\intbl " ++ contents ++ "\\cell}\n"
spaceAtEnd :: String -> String
spaceAtEnd str =
if isSuffixOf "\\par}\n" str
then (take ((length str) 6) str) ++ "\\sa180\\par}\n"
else str
listItemToRTF :: Alignment
-> Int
-> String
-> [Block]
-> [Char]
listItemToRTF alignment indent marker [] =
rtfCompact (indent + listIncrement) (0 listIncrement) alignment
(marker ++ "\\tx" ++ (show listIncrement) ++ "\\tab ")
listItemToRTF alignment indent marker list =
let (first:rest) = map (blockToRTF (indent + listIncrement) alignment) list
listMarker = "\\fi" ++ show (0 listIncrement) ++ " " ++ marker ++ "\\tx" ++
show listIncrement ++ "\\tab"
insertListMarker ('\\':'f':'i':'-':d:xs) | isDigit d =
listMarker ++ dropWhile isDigit xs
insertListMarker ('\\':'f':'i':d:xs) | isDigit d =
listMarker ++ dropWhile isDigit xs
insertListMarker (x:xs) =
x : insertListMarker xs
insertListMarker [] = []
in insertListMarker first ++ concat rest
definitionListItemToRTF :: Alignment
-> Int
-> ([Inline],[[Block]])
-> [Char]
definitionListItemToRTF alignment indent (label, defs) =
let labelText = blockToRTF indent alignment (Plain label)
itemsText = concatMap (blockToRTF (indent + listIncrement) alignment) $
concat defs
in labelText ++ itemsText
inlineListToRTF :: [Inline]
-> String
inlineListToRTF lst = concatMap inlineToRTF lst
inlineToRTF :: Inline
-> String
inlineToRTF (Emph lst) = "{\\i " ++ (inlineListToRTF lst) ++ "}"
inlineToRTF (Strong lst) = "{\\b " ++ (inlineListToRTF lst) ++ "}"
inlineToRTF (Strikeout lst) = "{\\strike " ++ (inlineListToRTF lst) ++ "}"
inlineToRTF (Superscript lst) = "{\\super " ++ (inlineListToRTF lst) ++ "}"
inlineToRTF (Subscript lst) = "{\\sub " ++ (inlineListToRTF lst) ++ "}"
inlineToRTF (SmallCaps lst) = "{\\scaps " ++ (inlineListToRTF lst) ++ "}"
inlineToRTF (Quoted SingleQuote lst) =
"\\u8216'" ++ (inlineListToRTF lst) ++ "\\u8217'"
inlineToRTF (Quoted DoubleQuote lst) =
"\\u8220\"" ++ (inlineListToRTF lst) ++ "\\u8221\""
inlineToRTF Apostrophe = "\\u8217'"
inlineToRTF Ellipses = "\\u8230?"
inlineToRTF EmDash = "\\u8212-"
inlineToRTF EnDash = "\\u8211-"
inlineToRTF (Code _ str) = "{\\f1 " ++ (codeStringToRTF str) ++ "}"
inlineToRTF (Str str) = stringToRTF str
inlineToRTF (Math _ str) = inlineListToRTF $ readTeXMath str
inlineToRTF (Cite _ lst) = inlineListToRTF lst
inlineToRTF (RawInline "rtf" str) = str
inlineToRTF (RawInline _ _) = ""
inlineToRTF (LineBreak) = "\\line "
inlineToRTF Space = " "
inlineToRTF (Link text (src, _)) =
"{\\field{\\*\\fldinst{HYPERLINK \"" ++ (codeStringToRTF src) ++
"\"}}{\\fldrslt{\\ul\n" ++ (inlineListToRTF text) ++ "\n}}}\n"
inlineToRTF (Image _ (source, _)) =
"{\\cf1 [image: " ++ source ++ "]\\cf0}"
inlineToRTF (Note contents) =
"{\\super\\chftn}{\\*\\footnote\\chftn\\~\\plain\\pard " ++
(concatMap (blockToRTF 0 AlignDefault) contents) ++ "}"