module Text.Pandoc.Writers.Texinfo ( writeTexinfo ) where
import Text.Pandoc.Definition
import Text.Pandoc.Shared
import Text.Pandoc.Templates (renderTemplate)
import Text.Pandoc.Readers.TeXMath
import Text.Printf ( printf )
import Data.List ( isSuffixOf, transpose, maximumBy )
import Data.Ord ( comparing )
import Data.Char ( chr, ord )
import Control.Monad.State
import Text.PrettyPrint.HughesPJ hiding ( Str )
data WriterState =
WriterState { stStrikeout :: Bool
, stSuperscript :: Bool
, stSubscript :: Bool
}
writeTexinfo :: WriterOptions -> Pandoc -> String
writeTexinfo options document =
evalState (pandocToTexinfo options $ wrapTop document) $
WriterState { stStrikeout = False, stSuperscript = False, stSubscript = False }
wrapTop :: Pandoc -> Pandoc
wrapTop (Pandoc (Meta title authors date) blocks) =
Pandoc (Meta title authors date) (Header 0 title : blocks)
pandocToTexinfo :: WriterOptions -> Pandoc -> State WriterState String
pandocToTexinfo options (Pandoc (Meta title authors date) blocks) = do
titleText <- inlineListToTexinfo title
authorsText <- mapM inlineListToTexinfo authors
dateText <- inlineListToTexinfo date
let titlePage = not $ all null $ title : date : authors
main <- blockListToTexinfo blocks
st <- get
let body = render main
let context = writerVariables options ++
[ ("body", body)
, ("title", render titleText)
, ("date", render dateText) ] ++
[ ("toc", "yes") | writerTableOfContents options ] ++
[ ("titlepage", "yes") | titlePage ] ++
[ ("subscript", "yes") | stSubscript st ] ++
[ ("superscript", "yes") | stSuperscript st ] ++
[ ("strikeout", "yes") | stStrikeout st ] ++
[ ("author", render a) | a <- authorsText ]
if writerStandalone options
then return $ renderTemplate context $ writerTemplate options
else return body
stringToTexinfo :: String -> String
stringToTexinfo = escapeStringUsing texinfoEscapes
where texinfoEscapes = [ ('{', "@{")
, ('}', "@}")
, ('@', "@@")
, (',', "@comma{}")
, ('\160', "@ ")
]
inCmd :: String -> Doc -> Doc
inCmd cmd contents = char '@' <> text cmd <> braces contents
blockToTexinfo :: Block
-> State WriterState Doc
blockToTexinfo Null = return empty
blockToTexinfo (Plain lst) =
inlineListToTexinfo lst
blockToTexinfo (Para [Image txt (src,tit)]) = do
capt <- inlineListToTexinfo txt
img <- inlineToTexinfo (Image txt (src,tit))
return $ text "@float" $$ img $$ (text "@caption{" <> capt <> char '}') $$
text "@end float"
blockToTexinfo (Para lst) =
inlineListToTexinfo lst
blockToTexinfo (BlockQuote lst) = do
contents <- blockListToTexinfo lst
return $ text "@quotation" $$
contents $$
text "@end quotation"
blockToTexinfo (CodeBlock _ str) = do
return $ text "@verbatim" $$
vcat (map text (lines str)) $$
text "@end verbatim\n"
blockToTexinfo (RawHtml _) = return empty
blockToTexinfo (BulletList lst) = do
items <- mapM listItemToTexinfo lst
return $ text "@itemize" $$
vcat items $$
text "@end itemize\n"
blockToTexinfo (OrderedList (start, numstyle, _) lst) = do
items <- mapM listItemToTexinfo lst
return $ text "@enumerate " <> exemplar $$
vcat items $$
text "@end enumerate\n"
where
exemplar = case numstyle of
DefaultStyle -> decimal
Decimal -> decimal
UpperRoman -> decimal
LowerRoman -> decimal
UpperAlpha -> upperAlpha
LowerAlpha -> lowerAlpha
decimal = if start == 1
then empty
else text (show start)
upperAlpha = text [chr $ ord 'A' + start 1]
lowerAlpha = text [chr $ ord 'a' + start 1]
blockToTexinfo (DefinitionList lst) = do
items <- mapM defListItemToTexinfo lst
return $ text "@table @asis" $$
vcat items $$
text "@end table\n"
blockToTexinfo HorizontalRule =
return $ text "@iftex" $$
text "@bigskip@hrule@bigskip" $$
text "@end iftex" $$
text "@ifnottex" $$
text (take 72 $ repeat '-') $$
text "@end ifnottex"
blockToTexinfo (Header 0 lst) = do
txt <- if null lst
then return $ text "Top"
else inlineListToTexinfo lst
return $ text "@node Top" $$
text "@top " <> txt <> char '\n'
blockToTexinfo (Header level lst) = do
node <- inlineListForNode lst
txt <- inlineListToTexinfo lst
return $ if (level > 0) && (level <= 4)
then text "\n@node " <> node <> char '\n' <>
text (seccmd level) <> txt
else txt
where
seccmd 1 = "@chapter "
seccmd 2 = "@section "
seccmd 3 = "@subsection "
seccmd 4 = "@subsubsection "
seccmd _ = error "illegal seccmd level"
blockToTexinfo (Table caption aligns widths heads rows) = do
headers <- if all null heads
then return empty
else tableHeadToTexinfo aligns heads
captionText <- inlineListToTexinfo caption
rowsText <- mapM (tableRowToTexinfo aligns) rows
colDescriptors <-
if all (== 0) widths
then do
cols <- mapM (mapM (liftM (render . hcat) . mapM blockToTexinfo)) $
transpose $ heads : rows
return $ concatMap ((\x -> "{"++x++"} ") . maximumBy (comparing length)) cols
else return $ "@columnfractions " ++ concatMap (printf "%.2f ") widths
let tableBody = text ("@multitable " ++ colDescriptors) $$
headers $$
vcat rowsText $$
text "@end multitable"
return $ if isEmpty captionText
then tableBody <> char '\n'
else text "@float" $$
tableBody $$
inCmd "caption" captionText $$
text "@end float"
tableHeadToTexinfo :: [Alignment]
-> [[Block]]
-> State WriterState Doc
tableHeadToTexinfo = tableAnyRowToTexinfo "@headitem "
tableRowToTexinfo :: [Alignment]
-> [[Block]]
-> State WriterState Doc
tableRowToTexinfo = tableAnyRowToTexinfo "@item "
tableAnyRowToTexinfo :: String
-> [Alignment]
-> [[Block]]
-> State WriterState Doc
tableAnyRowToTexinfo itemtype aligns cols =
zipWithM alignedBlock aligns cols >>=
return . (text itemtype $$) . foldl (\row item -> row $$
(if isEmpty row then empty else text " @tab ") <> item) empty
alignedBlock :: Alignment
-> [Block]
-> State WriterState Doc
alignedBlock _ = blockListToTexinfo
blockListToTexinfo :: [Block]
-> State WriterState Doc
blockListToTexinfo [] = return $ empty
blockListToTexinfo (x:xs) = do
x' <- blockToTexinfo x
case x of
Header level _ -> do
let (before, after) = break isHeader xs
before' <- blockListToTexinfo before
let menu = if level < 4
then collectNodes (level + 1) after
else []
lines' <- mapM makeMenuLine menu
let menu' = if null lines'
then empty
else text "@menu" $$
vcat lines' $$
text "@end menu"
after' <- blockListToTexinfo after
return $ x' $$ before' $$ menu' $$ after'
Para _ -> do
xs' <- blockListToTexinfo xs
case xs of
((CodeBlock _ _):_) -> return $ x' $$ xs'
_ -> return $ x' $$ text "" $$ xs'
_ -> do
xs' <- blockListToTexinfo xs
return $ x' $$ xs'
isHeader :: Block -> Bool
isHeader (Header _ _) = True
isHeader _ = False
collectNodes :: Int -> [Block] -> [Block]
collectNodes _ [] = []
collectNodes level (x:xs) =
case x of
(Header hl _) ->
if hl < level
then []
else if hl == level
then x : collectNodes level xs
else collectNodes level xs
_ ->
collectNodes level xs
makeMenuLine :: Block
-> State WriterState Doc
makeMenuLine (Header _ lst) = do
txt <- inlineListForNode lst
return $ text "* " <> txt <> text "::"
makeMenuLine _ = error "makeMenuLine called with non-Header block"
listItemToTexinfo :: [Block]
-> State WriterState Doc
listItemToTexinfo lst = blockListToTexinfo lst >>=
return . (text "@item" $$)
defListItemToTexinfo :: ([Inline], [[Block]])
-> State WriterState Doc
defListItemToTexinfo (term, defs) = do
term' <- inlineListToTexinfo term
def' <- liftM vcat $ mapM blockListToTexinfo defs
return $ text "@item " <> term' <> text "\n" $$ def'
inlineListToTexinfo :: [Inline]
-> State WriterState Doc
inlineListToTexinfo lst = mapM inlineToTexinfo lst >>= return . hcat
inlineListForNode :: [Inline]
-> State WriterState Doc
inlineListForNode lst = mapM inlineForNode lst >>= return . hcat
inlineForNode :: Inline -> State WriterState Doc
inlineForNode (Str str) = return $ text $ filter (not.disallowedInNode) str
inlineForNode (Emph lst) = inlineListForNode lst
inlineForNode (Strong lst) = inlineListForNode lst
inlineForNode (Strikeout lst) = inlineListForNode lst
inlineForNode (Superscript lst) = inlineListForNode lst
inlineForNode (Subscript lst) = inlineListForNode lst
inlineForNode (SmallCaps lst) = inlineListForNode lst
inlineForNode (Quoted _ lst) = inlineListForNode lst
inlineForNode (Cite _ lst) = inlineListForNode lst
inlineForNode (Code str) = inlineForNode (Str str)
inlineForNode Space = return $ char ' '
inlineForNode EmDash = return $ text "---"
inlineForNode EnDash = return $ text "--"
inlineForNode Apostrophe = return $ char '\''
inlineForNode Ellipses = return $ text "..."
inlineForNode LineBreak = return empty
inlineForNode (Math _ str) = inlineListForNode $ readTeXMath str
inlineForNode (TeX _) = return empty
inlineForNode (HtmlInline _) = return empty
inlineForNode (Link lst _) = inlineListForNode lst
inlineForNode (Image lst _) = inlineListForNode lst
inlineForNode (Note _) = return empty
disallowedInNode :: Char -> Bool
disallowedInNode c = c `elem` ".,:()"
inlineToTexinfo :: Inline
-> State WriterState Doc
inlineToTexinfo (Emph lst) =
inlineListToTexinfo lst >>= return . inCmd "emph"
inlineToTexinfo (Strong lst) =
inlineListToTexinfo lst >>= return . inCmd "strong"
inlineToTexinfo (Strikeout lst) = do
modify $ \st -> st{ stStrikeout = True }
contents <- inlineListToTexinfo lst
return $ text "@textstrikeout{" <> contents <> text "}"
inlineToTexinfo (Superscript lst) = do
modify $ \st -> st{ stSuperscript = True }
contents <- inlineListToTexinfo lst
return $ text "@textsuperscript{" <> contents <> char '}'
inlineToTexinfo (Subscript lst) = do
modify $ \st -> st{ stSubscript = True }
contents <- inlineListToTexinfo lst
return $ text "@textsubscript{" <> contents <> char '}'
inlineToTexinfo (SmallCaps lst) =
inlineListToTexinfo lst >>= return . inCmd "sc"
inlineToTexinfo (Code str) = do
return $ text $ "@code{" ++ stringToTexinfo str ++ "}"
inlineToTexinfo (Quoted SingleQuote lst) = do
contents <- inlineListToTexinfo lst
return $ char '`' <> contents <> char '\''
inlineToTexinfo (Quoted DoubleQuote lst) = do
contents <- inlineListToTexinfo lst
return $ text "``" <> contents <> text "''"
inlineToTexinfo (Cite _ lst) =
inlineListToTexinfo lst
inlineToTexinfo Apostrophe = return $ char '\''
inlineToTexinfo EmDash = return $ text "---"
inlineToTexinfo EnDash = return $ text "--"
inlineToTexinfo Ellipses = return $ text "@dots{}"
inlineToTexinfo (Str str) = return $ text (stringToTexinfo str)
inlineToTexinfo (Math _ str) = return $ inCmd "math" $ text str
inlineToTexinfo (TeX str) = return $ text "@tex" $$ text str $$ text "@end tex"
inlineToTexinfo (HtmlInline _) = return empty
inlineToTexinfo (LineBreak) = return $ text "@*"
inlineToTexinfo Space = return $ char ' '
inlineToTexinfo (Link txt (src, _)) = do
case txt of
[Code x] | x == src ->
do return $ text $ "@url{" ++ x ++ "}"
_ -> do contents <- inlineListToTexinfo txt
let src1 = stringToTexinfo src
return $ text ("@uref{" ++ src1 ++ ",") <> contents <>
char '}'
inlineToTexinfo (Image alternate (source, _)) = do
content <- inlineListToTexinfo alternate
return $ text ("@image{" ++ base ++ ",,,") <> content <> text "," <>
text (ext ++ "}")
where
(revext, revbase) = break (=='.') (reverse source)
ext = reverse revext
base = case revbase of
('.' : rest) -> reverse rest
_ -> reverse revbase
inlineToTexinfo (Note contents) = do
contents' <- blockListToTexinfo contents
let rawnote = stripTrailingNewlines $ render contents'
let optNewline = "@end verbatim" `isSuffixOf` rawnote
return $ text "@footnote{" <>
text rawnote <>
(if optNewline then char '\n' else empty) <>
char '}'