{-# LANGUAGE NoImplicitPrelude #-} {- Copyright (C) 2007-2018 John MacFarlane 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.Ms Copyright : Copyright (C) 2007-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane Stability : alpha Portability : portable Conversion of 'Pandoc' documents to groff ms format. TODO: [ ] use base URL to construct absolute URLs from relative ones for external links [ ] is there a better way to do strikeout? [ ] tight/loose list distinction -} module Text.Pandoc.Writers.Ms ( writeMs ) where import Prelude import Control.Monad.State.Strict import Data.Char (isLower, isUpper, toUpper, ord) import Data.List (intercalate, intersperse, sort) import qualified Data.Map as Map import Data.Maybe (catMaybes, fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Network.URI (escapeURIString, isAllowedInURI) import Skylighting import System.FilePath (takeExtension) import Text.Pandoc.Asciify (toAsciiChar) import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition import Text.Pandoc.Highlighting import Text.Pandoc.ImageSize import Text.Pandoc.Logging import Text.Pandoc.Options import Text.Pandoc.Pretty import Text.Pandoc.Shared import Text.Pandoc.Templates import Text.Pandoc.Writers.Math import Text.Pandoc.Writers.Shared import Text.Printf (printf) import Text.TeXMath (writeEqn) data WriterState = WriterState { stHasInlineMath :: Bool , stFirstPara :: Bool , stNotes :: [Note] , stSmallCaps :: Bool , stHighlighting :: Bool , stFontFeatures :: Map.Map Char Bool } defaultWriterState :: WriterState defaultWriterState = WriterState{ stHasInlineMath = False , stFirstPara = True , stNotes = [] , stSmallCaps = False , stHighlighting = False , stFontFeatures = Map.fromList [ ('I',False) , ('B',False) , ('C',False) ] } type Note = [Block] type MS = StateT WriterState -- | Convert Pandoc to Ms. writeMs :: PandocMonad m => WriterOptions -> Pandoc -> m Text writeMs opts document = evalStateT (pandocToMs opts document) defaultWriterState -- | Return groff ms representation of document. pandocToMs :: PandocMonad m => WriterOptions -> Pandoc -> MS m Text pandocToMs opts (Pandoc meta blocks) = do let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing let render' :: Doc -> Text render' = render colwidth metadata <- metaToJSON opts (fmap render' . blockListToMs opts) (fmap render' . inlineListToMs' opts) meta body <- blockListToMs opts blocks let main = render' body hasInlineMath <- gets stHasInlineMath let titleMeta = (escapeString . stringify) $ docTitle meta let authorsMeta = map (escapeString . stringify) $ docAuthors meta hasHighlighting <- gets stHighlighting let highlightingMacros = if hasHighlighting then case writerHighlightStyle opts of Nothing -> mempty Just sty -> render' $ styleToMs sty else mempty let context = defField "body" main $ defField "has-inline-math" hasInlineMath $ defField "hyphenate" True $ defField "pandoc-version" pandocVersion $ defField "toc" (writerTableOfContents opts) $ defField "title-meta" titleMeta $ defField "author-meta" (intercalate "; " authorsMeta) $ defField "highlighting-macros" highlightingMacros metadata case writerTemplate opts of Nothing -> return main Just tpl -> renderTemplate' tpl context -- | Association list of characters to escape. msEscapes :: Map.Map Char String msEscapes = Map.fromList [ ('\160', "\\~") , ('\'', "\\[aq]") , ('`', "\\`") , ('\8217', "'") , ('"', "\\[dq]") , ('\x2014', "\\[em]") , ('\x2013', "\\[en]") , ('\x2026', "\\&...") , ('~', "\\[ti]") , ('^', "\\[ha]") , ('-', "\\-") , ('@', "\\@") , ('\\', "\\\\") ] escapeChar :: Char -> String escapeChar c = fromMaybe [c] (Map.lookup c msEscapes) -- | Escape | character, used to mark inline math, inside math. escapeBar :: String -> String escapeBar = concatMap go where go '|' = "\\[u007C]" go c = [c] -- | Escape special characters for Ms. escapeString :: String -> String escapeString = concatMap escapeChar escapeUri :: String -> String escapeUri = escapeURIString (\c -> c /= '@' && isAllowedInURI c) toSmallCaps :: String -> String toSmallCaps [] = [] toSmallCaps (c:cs) | isLower c = let (lowers,rest) = span isLower (c:cs) in "\\s-2" ++ escapeString (map toUpper lowers) ++ "\\s0" ++ toSmallCaps rest | isUpper c = let (uppers,rest) = span isUpper (c:cs) in escapeString uppers ++ toSmallCaps rest | otherwise = escapeChar c ++ toSmallCaps cs -- | Escape a literal (code) section for Ms. escapeCode :: String -> String escapeCode = intercalate "\n" . map escapeLine . lines where escapeCodeChar ' ' = "\\ " escapeCodeChar '\t' = "\\\t" escapeCodeChar c = escapeChar c escapeLine codeline = case concatMap escapeCodeChar codeline of a@('.':_) -> "\\&" ++ a b -> b -- We split inline lists into sentences, and print one sentence per -- line. groff/troff treats the line-ending period differently. -- See http://code.google.com/p/pandoc/issues/detail?id=148. -- | Returns the first sentence in a list of inlines, and the rest. breakSentence :: [Inline] -> ([Inline], [Inline]) breakSentence [] = ([],[]) breakSentence xs = let isSentenceEndInline (Str ys@(_:_)) | last ys == '.' = True isSentenceEndInline (Str ys@(_:_)) | last ys == '?' = True isSentenceEndInline LineBreak = True isSentenceEndInline _ = False (as, bs) = break isSentenceEndInline xs in case bs of [] -> (as, []) [c] -> (as ++ [c], []) (c:Space:cs) -> (as ++ [c], cs) (c:SoftBreak:cs) -> (as ++ [c], cs) (Str ".":Str (')':ys):cs) -> (as ++ [Str ".", Str (')':ys)], cs) (x@(Str ('.':')':_)):cs) -> (as ++ [x], cs) (LineBreak:x@(Str ('.':_)):cs) -> (as ++[LineBreak], x:cs) (c:cs) -> (as ++ [c] ++ ds, es) where (ds, es) = breakSentence cs -- | Split a list of inlines into sentences. splitSentences :: [Inline] -> [[Inline]] splitSentences xs = let (sent, rest) = breakSentence xs in if null rest then [sent] else sent : splitSentences rest blockToMs :: PandocMonad m => WriterOptions -- ^ Options -> Block -- ^ Block element -> MS m Doc blockToMs _ Null = return empty blockToMs opts (Div _ bs) = do setFirstPara res <- blockListToMs opts bs setFirstPara return res blockToMs opts (Plain inlines) = liftM vcat $ mapM (inlineListToMs' opts) $ splitSentences inlines blockToMs opts (Para [Image attr alt (src,_tit)]) | let ext = takeExtension src in (ext == ".ps" || ext == ".eps") = do let (mbW,mbH) = (inPoints opts <$> dimension Width attr, inPoints opts <$> dimension Height attr) let sizeAttrs = case (mbW, mbH) of (Just wp, Nothing) -> space <> doubleQuotes (text (show (floor wp :: Int) ++ "p")) (Just wp, Just hp) -> space <> doubleQuotes (text (show (floor wp :: Int) ++ "p")) <> space <> doubleQuotes (text (show (floor hp :: Int))) _ -> empty capt <- inlineListToMs' opts alt return $ nowrap (text ".PSPIC -C " <> doubleQuotes (text (escapeString src)) <> sizeAttrs) $$ text ".ce 1000" $$ capt $$ text ".ce 0" blockToMs opts (Para inlines) = do firstPara <- gets stFirstPara resetFirstPara contents <- liftM vcat $ mapM (inlineListToMs' opts) $ splitSentences inlines return $ text (if firstPara then ".LP" else ".PP") $$ contents blockToMs _ b@(RawBlock f str) | f == Format "ms" = return $ text str | otherwise = do report $ BlockNotRendered b return empty blockToMs _ HorizontalRule = do resetFirstPara return $ text ".HLINE" blockToMs opts (Header level (ident,classes,_) inlines) = do setFirstPara contents <- inlineListToMs' opts $ map breakToSpace inlines let (heading, secnum) = if writerNumberSections opts && "unnumbered" `notElem` classes then (".NH", "\\*[SN]") else (".SH", "") let anchor = if null ident then empty else nowrap $ text ".pdfhref M " <> doubleQuotes (text (toAscii ident)) let bookmark = text ".pdfhref O " <> text (show level ++ " ") <> doubleQuotes (text $ secnum ++ (if null secnum then "" else " ") ++ escapeString (stringify inlines)) let backlink = nowrap (text ".pdfhref L -D " <> doubleQuotes (text (toAscii ident)) <> space <> text "\\") <> cr <> text " -- " let tocEntry = if writerTableOfContents opts && level <= writerTOCDepth opts then text ".XS" $$ backlink <> doubleQuotes ( nowrap (text (replicate level '\t') <> (if null secnum then empty else text secnum <> text "\\~\\~") <> contents)) $$ text ".XE" else empty modify $ \st -> st{ stFirstPara = True } return $ (text heading <> space <> text (show level)) $$ contents $$ bookmark $$ anchor $$ tocEntry blockToMs opts (CodeBlock attr str) = do hlCode <- highlightCode opts attr str setFirstPara return $ text ".IP" $$ text ".nf" $$ text "\\f[C]" $$ hlCode $$ text "\\f[]" $$ text ".fi" blockToMs opts (LineBlock ls) = do resetFirstPara blockToMs opts $ Para $ intercalate [LineBreak] ls blockToMs opts (BlockQuote blocks) = do setFirstPara contents <- blockListToMs opts blocks setFirstPara return $ text ".RS" $$ contents $$ text ".RE" blockToMs opts (Table caption alignments widths headers rows) = let aligncode AlignLeft = "l" aligncode AlignRight = "r" aligncode AlignCenter = "c" aligncode AlignDefault = "l" in do caption' <- inlineListToMs' opts caption let iwidths = if all (== 0) widths then repeat "" else map (printf "w(%0.1fn)" . (70 *)) widths -- 78n default width - 8n indent = 70n let coldescriptions = text $ unwords (zipWith (\align width -> aligncode align ++ width) alignments iwidths) ++ "." colheadings <- mapM (blockListToMs opts) headers let makeRow cols = text "T{" $$ vcat (intersperse (text "T}\tT{") cols) $$ text "T}" let colheadings' = if all null headers then empty else makeRow colheadings $$ char '_' body <- mapM (\row -> do cols <- mapM (blockListToMs opts) row return $ makeRow cols) rows setFirstPara return $ text ".PP" $$ caption' $$ text ".TS" $$ text "delim(@@) tab(\t);" $$ coldescriptions $$ colheadings' $$ vcat body $$ text ".TE" blockToMs opts (BulletList items) = do contents <- mapM (bulletListItemToMs opts) items setFirstPara return (vcat contents) blockToMs opts (OrderedList attribs items) = do let markers = take (length items) $ orderedListMarkers attribs let indent = 2 + maximum (map length markers) contents <- mapM (\(num, item) -> orderedListItemToMs opts num indent item) $ zip markers items setFirstPara return (vcat contents) blockToMs opts (DefinitionList items) = do contents <- mapM (definitionListItemToMs opts) items setFirstPara return (vcat contents) -- | Convert bullet list item (list of blocks) to ms. bulletListItemToMs :: PandocMonad m => WriterOptions -> [Block] -> MS m Doc bulletListItemToMs _ [] = return empty bulletListItemToMs opts (Para first:rest) = bulletListItemToMs opts (Plain first:rest) bulletListItemToMs opts (Plain first:rest) = do first' <- blockToMs opts (Plain first) rest' <- blockListToMs opts rest let first'' = text ".IP \\[bu] 3" $$ first' let rest'' = if null rest then empty else text ".RS 3" $$ rest' $$ text ".RE" return (first'' $$ rest'') bulletListItemToMs opts (first:rest) = do first' <- blockToMs opts first rest' <- blockListToMs opts rest return $ text "\\[bu] .RS 3" $$ first' $$ rest' $$ text ".RE" -- | Convert ordered list item (a list of blocks) to ms. orderedListItemToMs :: PandocMonad m => WriterOptions -- ^ options -> String -- ^ order marker for list item -> Int -- ^ number of spaces to indent -> [Block] -- ^ list item (list of blocks) -> MS m Doc orderedListItemToMs _ _ _ [] = return empty orderedListItemToMs opts num indent (Para first:rest) = orderedListItemToMs opts num indent (Plain first:rest) orderedListItemToMs opts num indent (first:rest) = do first' <- blockToMs opts first rest' <- blockListToMs opts rest let num' = printf ("%" ++ show (indent - 1) ++ "s") num let first'' = text (".IP \"" ++ num' ++ "\" " ++ show indent) $$ first' let rest'' = if null rest then empty else text ".RS " <> text (show indent) $$ rest' $$ text ".RE" return $ first'' $$ rest'' -- | Convert definition list item (label, list of blocks) to ms. definitionListItemToMs :: PandocMonad m => WriterOptions -> ([Inline],[[Block]]) -> MS m Doc definitionListItemToMs opts (label, defs) = do labelText <- inlineListToMs' opts $ map breakToSpace label contents <- if null defs then return empty else liftM vcat $ forM defs $ \blocks -> do let (first, rest) = case blocks of (Para x:y) -> (Plain x,y) (x:y) -> (x,y) [] -> (Plain [], []) -- should not happen rest' <- liftM vcat $ mapM (\item -> blockToMs opts item) rest first' <- blockToMs opts first return $ first' $$ text ".RS" $$ rest' $$ text ".RE" return $ nowrap (text ".IP " <> doubleQuotes labelText) $$ contents -- | Convert list of Pandoc block elements to ms. blockListToMs :: PandocMonad m => WriterOptions -- ^ Options -> [Block] -- ^ List of block elements -> MS m Doc blockListToMs opts blocks = mapM (blockToMs opts) blocks >>= (return . vcat) -- | Convert list of Pandoc inline elements to ms. inlineListToMs :: PandocMonad m => WriterOptions -> [Inline] -> MS m Doc -- if list starts with ., insert a zero-width character \& so it -- won't be interpreted as markup if it falls at the beginning of a line. inlineListToMs opts lst = hcat <$> mapM (inlineToMs opts) lst -- This version to be used when there is no further inline content; -- forces a note at the end. inlineListToMs' :: PandocMonad m => WriterOptions -> [Inline] -> MS m Doc inlineListToMs' opts lst = do x <- hcat <$> mapM (inlineToMs opts) lst y <- handleNotes opts empty return $ x <> y -- | Convert Pandoc inline element to ms. inlineToMs :: PandocMonad m => WriterOptions -> Inline -> MS m Doc inlineToMs opts (Span _ ils) = inlineListToMs opts ils inlineToMs opts (Emph lst) = withFontFeature 'I' (inlineListToMs opts lst) inlineToMs opts (Strong lst) = withFontFeature 'B' (inlineListToMs opts lst) inlineToMs opts (Strikeout lst) = do contents <- inlineListToMs opts lst -- we use grey color instead of strikeout, which seems quite -- hard to do in groff for arbitrary bits of text return $ text "\\m[strikecolor]" <> contents <> text "\\m[]" inlineToMs opts (Superscript lst) = do contents <- inlineListToMs opts lst return $ text "\\*{" <> contents <> text "\\*}" inlineToMs opts (Subscript lst) = do contents <- inlineListToMs opts lst return $ text "\\*<" <> contents <> text "\\*>" inlineToMs opts (SmallCaps lst) = do -- see https://lists.gnu.org/archive/html/groff/2015-01/msg00016.html modify $ \st -> st{ stSmallCaps = not (stSmallCaps st) } res <- inlineListToMs opts lst modify $ \st -> st{ stSmallCaps = not (stSmallCaps st) } return res inlineToMs opts (Quoted SingleQuote lst) = do contents <- inlineListToMs opts lst return $ char '`' <> contents <> char '\'' inlineToMs opts (Quoted DoubleQuote lst) = do contents <- inlineListToMs opts lst return $ text "\\[lq]" <> contents <> text "\\[rq]" inlineToMs opts (Cite _ lst) = inlineListToMs opts lst inlineToMs opts (Code attr str) = do hlCode <- highlightCode opts attr str withFontFeature 'C' (return hlCode) inlineToMs _ (Str str) = do let shim = case str of '.':_ -> afterBreak "\\&" _ -> empty smallcaps <- gets stSmallCaps if smallcaps then return $ shim <> text (toSmallCaps str) else return $ shim <> text (escapeString str) inlineToMs opts (Math InlineMath str) = do modify $ \st -> st{ stHasInlineMath = True } res <- convertMath writeEqn InlineMath str case res of Left il -> inlineToMs opts il Right r -> return $ text "@" <> text (escapeBar r) <> text "@" inlineToMs opts (Math DisplayMath str) = do res <- convertMath writeEqn InlineMath str case res of Left il -> do contents <- inlineToMs opts il return $ cr <> text ".RS" $$ contents $$ text ".RE" Right r -> return $ cr <> text ".EQ" $$ text (escapeBar r) $$ text ".EN" inlineToMs _ il@(RawInline f str) | f == Format "ms" = return $ text str | otherwise = do report $ InlineNotRendered il return empty inlineToMs _ LineBreak = return $ cr <> text ".br" <> cr inlineToMs opts SoftBreak = handleNotes opts $ case writerWrapText opts of WrapAuto -> space WrapNone -> space WrapPreserve -> cr inlineToMs opts Space = handleNotes opts space inlineToMs opts (Link _ txt ('#':ident, _)) = do -- internal link contents <- inlineListToMs' opts $ map breakToSpace txt return $ text "\\c" <> cr <> nowrap (text ".pdfhref L -D " <> doubleQuotes (text (toAscii ident)) <> text " -A " <> doubleQuotes (text "\\c") <> space <> text "\\") <> cr <> text " -- " <> doubleQuotes (nowrap contents) <> cr <> text "\\&" inlineToMs opts (Link _ txt (src, _)) = do -- external link contents <- inlineListToMs' opts $ map breakToSpace txt return $ text "\\c" <> cr <> nowrap (text ".pdfhref W -D " <> doubleQuotes (text (escapeUri src)) <> text " -A " <> doubleQuotes (text "\\c") <> space <> text "\\") <> cr <> text " -- " <> doubleQuotes (nowrap contents) <> cr <> text "\\&" inlineToMs _ (Image _ alternate (_, _)) = return $ char '[' <> text "IMAGE: " <> text (escapeString (stringify alternate)) <> char ']' inlineToMs _ (Note contents) = do modify $ \st -> st{ stNotes = contents : stNotes st } return $ text "\\**" handleNotes :: PandocMonad m => WriterOptions -> Doc -> MS m Doc handleNotes opts fallback = do notes <- gets stNotes if null notes then return fallback else do modify $ \st -> st{ stNotes = [] } vcat <$> mapM (handleNote opts) notes handleNote :: PandocMonad m => WriterOptions -> Note -> MS m Doc handleNote opts bs = do -- don't start with Paragraph or we'll get a spurious blank -- line after the note ref: let bs' = case bs of (Para ils : rest) -> Plain ils : rest _ -> bs contents <- blockListToMs opts bs' return $ cr <> text ".FS" $$ contents $$ text ".FE" <> cr fontChange :: PandocMonad m => MS m Doc fontChange = do features <- gets stFontFeatures let filling = sort [c | (c,True) <- Map.toList features] return $ text $ "\\f[" ++ filling ++ "]" withFontFeature :: PandocMonad m => Char -> MS m Doc -> MS m Doc withFontFeature c action = do modify $ \st -> st{ stFontFeatures = Map.adjust not c $ stFontFeatures st } begin <- fontChange d <- action modify $ \st -> st{ stFontFeatures = Map.adjust not c $ stFontFeatures st } end <- fontChange return $ begin <> d <> end setFirstPara :: PandocMonad m => MS m () setFirstPara = modify $ \st -> st{ stFirstPara = True } resetFirstPara :: PandocMonad m => MS m () resetFirstPara = modify $ \st -> st{ stFirstPara = False } breakToSpace :: Inline -> Inline breakToSpace SoftBreak = Space breakToSpace LineBreak = Space breakToSpace x = x -- Highlighting styleToMs :: Style -> Doc styleToMs sty = vcat $ colordefs ++ map (toMacro sty) alltoktypes where alltoktypes = enumFromTo KeywordTok NormalTok colordefs = map toColorDef allcolors toColorDef c = text (".defcolor " ++ hexColor c ++ " rgb #" ++ hexColor c) allcolors = catMaybes $ ordNub $ [defaultColor sty, backgroundColor sty, lineNumberColor sty, lineNumberBackgroundColor sty] ++ concatMap (colorsForToken. snd) (Map.toList (tokenStyles sty)) colorsForToken ts = [tokenColor ts, tokenBackground ts] hexColor :: Color -> String hexColor (RGB r g b) = printf "%02x%02x%02x" r g b toMacro :: Style -> TokenType -> Doc toMacro sty toktype = nowrap (text ".ds " <> text (show toktype) <> text " " <> setbg <> setcolor <> setfont <> text "\\\\$1" <> resetfont <> resetcolor <> resetbg) where setcolor = maybe empty fgcol tokCol resetcolor = maybe empty (const $ text "\\\\m[]") tokCol setbg = empty -- maybe empty bgcol tokBg resetbg = empty -- maybe empty (const $ text "\\\\M[]") tokBg fgcol c = text $ "\\\\m[" ++ hexColor c ++ "]" -- bgcol c = text $ "\\\\M[" ++ hexColor c ++ "]" setfont = if tokBold || tokItalic then text $ "\\\\f[C" ++ ['B' | tokBold] ++ ['I' | tokItalic] ++ "]" else empty resetfont = if tokBold || tokItalic then text "\\\\f[C]" else empty tokSty = Map.lookup toktype (tokenStyles sty) tokCol = (tokSty >>= tokenColor) `mplus` defaultColor sty -- tokBg = (tokSty >>= tokenBackground) `mplus` backgroundColor sty tokBold = fromMaybe False (tokenBold <$> tokSty) tokItalic = fromMaybe False (tokenItalic <$> tokSty) -- tokUnderline = fromMaybe False (tokSty >>= tokUnderline) -- lnColor = lineNumberColor sty -- lnBkgColor = lineNumberBackgroundColor sty msFormatter :: FormatOptions -> [SourceLine] -> Doc msFormatter _fmtopts = vcat . map fmtLine where fmtLine = hcat . map fmtToken fmtToken (toktype, tok) = text "\\*" <> brackets (text (show toktype) <> text " \"" <> text (escapeCode (T.unpack tok)) <> text "\"") highlightCode :: PandocMonad m => WriterOptions -> Attr -> String -> MS m Doc highlightCode opts attr str = case highlight (writerSyntaxMap opts) msFormatter attr str of Left msg -> do unless (null msg) $ report $ CouldNotHighlight msg return $ text (escapeCode str) Right h -> do modify (\st -> st{ stHighlighting = True }) return h toAscii :: String -> String toAscii = concatMap (\c -> case toAsciiChar c of Nothing -> 'u':show (ord c) Just c' -> [c'])