{-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2008-2015 John MacFarlane and Peter Wang 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.Texinfo Copyright : Copyright (C) 2008-2015 John MacFarlane and Peter Wang License : GNU GPL, version 2 or above Maintainer : John MacFarlane Stability : alpha Portability : portable Conversion of 'Pandoc' format into Texinfo. -} module Text.Pandoc.Writers.Texinfo ( writeTexinfo ) where import Text.Pandoc.Definition import Text.Pandoc.Options import Text.Pandoc.Shared import Text.Pandoc.Writers.Shared import Text.Pandoc.Templates (renderTemplate') import Text.Printf ( printf ) import Data.List ( transpose, maximumBy ) import Data.Ord ( comparing ) import Data.Char ( chr, ord ) import Control.Monad.State import Text.Pandoc.Pretty import Text.Pandoc.ImageSize import Network.URI ( isURI, unEscapeString ) import System.FilePath import qualified Data.Set as Set import Control.Monad.Except (throwError) import Text.Pandoc.Class ( PandocMonad, PandocExecutionError(..) ) data WriterState = WriterState { stStrikeout :: Bool -- document contains strikeout , stSuperscript :: Bool -- document contains superscript , stSubscript :: Bool -- document contains subscript , stEscapeComma :: Bool -- in a context where we need @comma , stIdentifiers :: Set.Set String -- header ids used already , stOptions :: WriterOptions -- writer options } {- TODO: - internal cross references a la HTML - generated .texi files don't work when run through texi2dvi -} type TI m = StateT WriterState m -- | Convert Pandoc to Texinfo. writeTexinfo :: PandocMonad m => WriterOptions -> Pandoc -> m String writeTexinfo options document = evalStateT (pandocToTexinfo options $ wrapTop document) $ WriterState { stStrikeout = False, stSuperscript = False, stEscapeComma = False, stSubscript = False, stIdentifiers = Set.empty, stOptions = options} -- | Add a "Top" node around the document, needed by Texinfo. wrapTop :: Pandoc -> Pandoc wrapTop (Pandoc meta blocks) = Pandoc meta (Header 0 nullAttr (docTitle meta) : blocks) pandocToTexinfo :: PandocMonad m => WriterOptions -> Pandoc -> TI m String pandocToTexinfo options (Pandoc meta blocks) = do let titlePage = not $ all null $ docTitle meta : docDate meta : docAuthors meta let colwidth = if writerWrapText options == WrapAuto then Just $ writerColumns options else Nothing metadata <- metaToJSON options (fmap (render colwidth) . blockListToTexinfo) (fmap (render colwidth) . inlineListToTexinfo) meta main <- blockListToTexinfo blocks st <- get let body = render colwidth main let context = defField "body" body $ defField "toc" (writerTableOfContents options) $ defField "titlepage" titlePage $ defField "subscript" (stSubscript st) $ defField "superscript" (stSuperscript st) $ defField "strikeout" (stStrikeout st) $ metadata case writerTemplate options of Nothing -> return body Just tpl -> return $ renderTemplate' tpl context -- | Escape things as needed for Texinfo. stringToTexinfo :: String -> String stringToTexinfo = escapeStringUsing texinfoEscapes where texinfoEscapes = [ ('{', "@{") , ('}', "@}") , ('@', "@@") , ('\160', "@ ") , ('\x2014', "---") , ('\x2013', "--") , ('\x2026', "@dots{}") , ('\x2019', "'") ] escapeCommas :: PandocMonad m => TI m Doc -> TI m Doc escapeCommas parser = do oldEscapeComma <- gets stEscapeComma modify $ \st -> st{ stEscapeComma = True } res <- parser modify $ \st -> st{ stEscapeComma = oldEscapeComma } return res -- | Puts contents into Texinfo command. inCmd :: String -> Doc -> Doc inCmd cmd contents = char '@' <> text cmd <> braces contents -- | Convert Pandoc block element to Texinfo. blockToTexinfo :: PandocMonad m => Block -- ^ Block to convert -> TI m Doc blockToTexinfo Null = return empty blockToTexinfo (Div _ bs) = blockListToTexinfo bs blockToTexinfo (Plain lst) = inlineListToTexinfo lst -- title beginning with fig: indicates that the image is a figure blockToTexinfo (Para [Image attr txt (src,'f':'i':'g':':':tit)]) = do capt <- if null txt then return empty else (\c -> text "@caption" <> braces c) `fmap` inlineListToTexinfo txt img <- inlineToTexinfo (Image attr txt (src,tit)) return $ text "@float" $$ img $$ capt $$ text "@end float" blockToTexinfo (Para lst) = inlineListToTexinfo lst -- this is handled differently from Plain in blockListToTexinfo blockToTexinfo (LineBlock lns) = blockToTexinfo $ linesToPara lns blockToTexinfo (BlockQuote lst) = do contents <- blockListToTexinfo lst return $ text "@quotation" $$ contents $$ text "@end quotation" blockToTexinfo (CodeBlock _ str) = do return $ blankline $$ text "@verbatim" $$ flush (text str) $$ text "@end verbatim" <> blankline blockToTexinfo (RawBlock f str) | f == "texinfo" = return $ text str | f == "latex" || f == "tex" = return $ text "@tex" $$ text str $$ text "@end tex" | otherwise = return empty blockToTexinfo (BulletList lst) = do items <- mapM listItemToTexinfo lst return $ text "@itemize" $$ vcat items $$ text "@end itemize" <> blankline blockToTexinfo (OrderedList (start, numstyle, _) lst) = do items <- mapM listItemToTexinfo lst return $ text "@enumerate " <> exemplar $$ vcat items $$ text "@end enumerate" <> blankline where exemplar = case numstyle of DefaultStyle -> decimal Decimal -> decimal Example -> decimal UpperRoman -> decimal -- Roman numerals not supported 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" <> blankline blockToTexinfo HorizontalRule = -- XXX can't get the equivalent from LaTeX.hs to work 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 <> blankline blockToTexinfo (Header level _ lst) = do node <- inlineListForNode lst txt <- inlineListToTexinfo lst idsUsed <- gets stIdentifiers let id' = uniqueIdent lst idsUsed modify $ \st -> st{ stIdentifiers = Set.insert id' idsUsed } sec <- seccmd level return $ if (level > 0) && (level <= 4) then blankline <> text "@node " <> node $$ text sec <> txt $$ text "@anchor" <> braces (text $ '#':id') else txt where seccmd :: PandocMonad m => Int -> TI m String seccmd 1 = return "@chapter " seccmd 2 = return "@section " seccmd 3 = return "@subsection " seccmd 4 = return "@subsubsection " seccmd _ = throwError $ PandocSomeError "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 -- use longest entry instead of column widths cols <- mapM (mapM (liftM (render Nothing . 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 <> blankline else text "@float" $$ tableBody $$ inCmd "caption" captionText $$ text "@end float" tableHeadToTexinfo :: PandocMonad m => [Alignment] -> [[Block]] -> TI m Doc tableHeadToTexinfo = tableAnyRowToTexinfo "@headitem " tableRowToTexinfo :: PandocMonad m => [Alignment] -> [[Block]] -> TI m Doc tableRowToTexinfo = tableAnyRowToTexinfo "@item " tableAnyRowToTexinfo :: PandocMonad m => String -> [Alignment] -> [[Block]] -> TI m 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 :: PandocMonad m => Alignment -> [Block] -> TI m Doc -- XXX @flushleft and @flushright text won't get word wrapped. Since word -- wrapping is more important than alignment, we ignore the alignment. alignedBlock _ = blockListToTexinfo {- alignedBlock AlignLeft col = do b <- blockListToTexinfo col return $ text "@flushleft" $$ b $$ text "@end flushleft" alignedBlock AlignRight col = do b <- blockListToTexinfo col return $ text "@flushright" $$ b $$ text "@end flushright" alignedBlock _ col = blockListToTexinfo col -} -- | Convert Pandoc block elements to Texinfo. blockListToTexinfo :: PandocMonad m => [Block] -> TI m Doc blockListToTexinfo [] = return empty blockListToTexinfo (x:xs) = do x' <- blockToTexinfo x case x of Header level _ _ -> do -- We need need to insert a menu for this node. let (before, after) = break isHeaderBlock 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' $+$ xs' _ -> do xs' <- blockListToTexinfo xs return $ x' $$ xs' 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 :: PandocMonad m => Block -> TI m Doc makeMenuLine (Header _ _ lst) = do txt <- inlineListForNode lst return $ text "* " <> txt <> text "::" makeMenuLine _ = throwError $ PandocSomeError "makeMenuLine called with non-Header block" listItemToTexinfo :: PandocMonad m => [Block] -> TI m Doc listItemToTexinfo lst = do contents <- blockListToTexinfo lst let spacer = case reverse lst of (Para{}:_) -> blankline _ -> empty return $ text "@item" $$ contents <> spacer defListItemToTexinfo :: PandocMonad m => ([Inline], [[Block]]) -> TI m Doc defListItemToTexinfo (term, defs) = do term' <- inlineListToTexinfo term let defToTexinfo bs = do d <- blockListToTexinfo bs case reverse bs of (Para{}:_) -> return $ d <> blankline _ -> return d defs' <- mapM defToTexinfo defs return $ text "@item " <> term' $+$ vcat defs' -- | Convert list of inline elements to Texinfo. inlineListToTexinfo :: PandocMonad m => [Inline] -- ^ Inlines to convert -> TI m Doc inlineListToTexinfo lst = mapM inlineToTexinfo lst >>= return . hcat -- | Convert list of inline elements to Texinfo acceptable for a node name. inlineListForNode :: PandocMonad m => [Inline] -- ^ Inlines to convert -> TI m Doc inlineListForNode = return . text . stringToTexinfo . filter (not . disallowedInNode) . stringify -- periods, commas, colons, and parentheses are disallowed in node names disallowedInNode :: Char -> Bool disallowedInNode c = c `elem` (".,:()" :: String) -- | Convert inline element to Texinfo inlineToTexinfo :: PandocMonad m => Inline -- ^ Inline to convert -> TI m Doc inlineToTexinfo (Span _ lst) = inlineListToTexinfo lst 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 (Str str) = return $ text (stringToTexinfo str) inlineToTexinfo (Math _ str) = return $ inCmd "math" $ text str inlineToTexinfo (RawInline f str) | f == "latex" || f == "tex" = return $ text "@tex" $$ text str $$ text "@end tex" | f == "texinfo" = return $ text str | otherwise = return empty inlineToTexinfo (LineBreak) = return $ text "@*" <> cr inlineToTexinfo SoftBreak = do wrapText <- gets (writerWrapText . stOptions) case wrapText of WrapAuto -> return space WrapNone -> return space WrapPreserve -> return cr inlineToTexinfo Space = return space inlineToTexinfo PageBreak = return $ text "@page" inlineToTexinfo (Link _ txt (src@('#':_), _)) = do contents <- escapeCommas $ inlineListToTexinfo txt return $ text "@ref" <> braces (text (stringToTexinfo src) <> text "," <> contents) inlineToTexinfo (Link _ txt (src, _)) = do case txt of [Str x] | escapeURI x == src -> -- autolink do return $ text $ "@url{" ++ x ++ "}" _ -> do contents <- escapeCommas $ inlineListToTexinfo txt let src1 = stringToTexinfo src return $ text ("@uref{" ++ src1 ++ ",") <> contents <> char '}' inlineToTexinfo (Image attr alternate (source, _)) = do content <- escapeCommas $ inlineListToTexinfo alternate opts <- gets stOptions let showDim dim = case (dimension dim attr) of (Just (Pixel a)) -> showInInch opts (Pixel a) ++ "in" (Just (Percent _)) -> "" (Just d) -> show d Nothing -> "" return $ text ("@image{" ++ base ++ ',':(showDim Width) ++ ',':(showDim Height) ++ ",") <> content <> text "," <> text (ext ++ "}") where ext = drop 1 $ takeExtension source' base = dropExtension source' source' = if isURI source then source else unEscapeString source inlineToTexinfo (Note contents) = do contents' <- blockListToTexinfo contents return $ text "@footnote" <> braces contents'