{-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2008-2017 John MacFarlane 2012 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-2017 John MacFarlane 2012 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 Control.Monad.Except (throwError) import Control.Monad.State.Strict import Data.Char (chr, ord) import Data.List (maximumBy, transpose) import Data.Ord (comparing) import qualified Data.Set as Set import Data.Text (Text) import Network.URI (unEscapeString) import System.FilePath import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.Error import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options import Text.Pandoc.Pretty import Text.Pandoc.Shared import Text.Pandoc.Templates (renderTemplate') import Text.Pandoc.Writers.Shared import Text.Printf (printf) 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 Text 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 Text 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 let render' :: Doc -> Text render' = render colwidth metadata <- metaToJSON options (fmap render' . blockListToTexinfo) (fmap render' . 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 -> 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) = return $ blankline $$ text "@verbatim" $$ flush (text str) $$ text "@end verbatim" <> blankline blockToTexinfo b@(RawBlock f str) | f == "texinfo" = return $ text str | f == "latex" || f == "tex" = return $ text "@tex" $$ text str $$ text "@end tex" | otherwise = do report $ BlockNotRendered b 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 (replicate 72 '-') $$ 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) | level < 1 || level > 4 = blockToTexinfo (Para lst) | otherwise = 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) = 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 il@(RawInline f str) | f == "latex" || f == "tex" = return $ text "@tex" $$ text str $$ text "@end tex" | f == "texinfo" = return $ text str | otherwise = do report $ InlineNotRendered il 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 (Link _ txt (src@('#':_), _)) = do contents <- escapeCommas $ inlineListToTexinfo txt return $ text "@ref" <> braces (text (stringToTexinfo src) <> text "," <> contents) inlineToTexinfo (Link _ txt (src, _)) = 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'