summaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Writers/Ms.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/Pandoc/Writers/Ms.hs')
-rw-r--r--src/Text/Pandoc/Writers/Ms.hs639
1 files changed, 639 insertions, 0 deletions
diff --git a/src/Text/Pandoc/Writers/Ms.hs b/src/Text/Pandoc/Writers/Ms.hs
new file mode 100644
index 000000000..83d80cd4a
--- /dev/null
+++ b/src/Text/Pandoc/Writers/Ms.hs
@@ -0,0 +1,639 @@
+{-
+Copyright (C) 2007-2018 John MacFarlane <jgm@berkeley.edu>
+
+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 <jgm@berkeley.edu>
+ 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 Control.Monad.State.Strict
+import Data.Char (isLower, isUpper, toUpper)
+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.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 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 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 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
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-21 22:27:23 +0000