Man writer: support syntax highlighting (limited).

Currently only boldface and italics are supported.
The `monochrome` style might be of use for those generating
man pages.

Closes #9446.

1 files changed, 43 insertions, 9 deletions

diff --git a/src/Text/Pandoc/Writers/Man.hs b/src/Text/Pandoc/Writers/Man.hs
index b1de1bffb..9496ff249 100644
--- a/src/Text/Pandoc/Writers/Man.hs
+++ b/src/Text/Pandoc/Writers/Man.hs
@@ -14,12 +14,13 @@ Conversion of 'Pandoc' documents to roff man page format.
 
 -}
 module Text.Pandoc.Writers.Man ( writeMan ) where
-import Control.Monad ( liftM, zipWithM, forM )
+import Control.Monad ( liftM, zipWithM, forM, unless )
 import Control.Monad.State.Strict ( StateT, gets, modify, evalStateT )
 import Control.Monad.Trans (MonadTrans(lift))
 import Data.List (intersperse)
 import Data.List.NonEmpty (nonEmpty)
 import Data.Maybe (fromMaybe)
+import qualified Data.Map as M
 import Data.Text (Text)
 import qualified Data.Text as T
 import Text.Pandoc.Builder (deleteMeta)
@@ -34,7 +35,10 @@ import Text.Pandoc.Templates (renderTemplate)
 import Text.Pandoc.Writers.Math
 import Text.Pandoc.Writers.Shared
 import Text.Pandoc.Writers.Roff
+import Text.Pandoc.Highlighting
 import Text.Printf (printf)
+import Skylighting (TokenType(..), SourceLine, FormatOptions, defaultFormatOpts,
+                    defStyle, TokenStyle(..), Style(..))
 
 -- | Convert Pandoc to Man.
 writeMan :: PandocMonad m => WriterOptions -> Pandoc -> m Text
@@ -129,14 +133,18 @@ blockToMan opts (Header level _ inlines) = do
                   1 -> ".SH "
                   _ -> ".SS "
   return $ nowrap $ literal heading <> contents
-blockToMan opts (CodeBlock _ str) = return $
-  literal ".IP" $$
-  literal ".EX" $$
-  ((case T.uncons str of
-    Just ('.',_) -> literal "\\&"
-    _            -> mempty) <>
-   literal (escString opts str)) $$
-  literal ".EE"
+blockToMan opts (CodeBlock attr str) = do
+  hlCode <- case highlight (writerSyntaxMap opts) (formatSource opts)
+                  attr str of
+              Right d -> pure d
+              Left msg -> do
+                unless (T.null msg) $ report $ CouldNotHighlight msg
+                pure $ formatSource opts defaultFormatOpts
+                          (map (\t -> [(NormalTok,t)]) $ T.lines str)
+  pure $ literal ".IP" $$
+         literal ".EX" $$
+         hlCode $$
+         literal ".EE"
 blockToMan opts (BlockQuote blocks) = do
   contents <- blockListToMan opts blocks
   return $ literal ".RS" $$ contents $$ literal ".RE"
@@ -340,3 +348,29 @@ inlineToMan _ (Note contents) = do
   notes <- gets stNotes
   let ref = tshow (length notes)
   return $ char '[' <> literal ref <> char ']'
+
+formatSource :: WriterOptions -> FormatOptions -> [SourceLine] -> Doc Text
+formatSource wopts fopts = vcat . map (formatSourceLine wopts fopts)
+
+formatSourceLine :: WriterOptions -> FormatOptions -> SourceLine -> Doc Text
+formatSourceLine _wopts _fopts [] = blankline
+formatSourceLine wopts fopts ts@((_,firstTxt):_) =
+  (case T.uncons firstTxt of
+     Just ('.',_) -> literal "\\&"
+     _ -> mempty) <> mconcat (map (formatTok wopts fopts) ts) <> literal "\n"
+
+formatTok :: WriterOptions -> FormatOptions -> (TokenType, Text) -> Doc Text
+formatTok wopts _fopts (toktype, t) =
+  let txt = literal (escString wopts t)
+      styleMap = tokenStyles <$> writerHighlightStyle wopts
+      tokStyle = fromMaybe defStyle $ styleMap >>= M.lookup toktype
+  in  if toktype == NormalTok
+         then txt
+         else
+           let fonts = ['B' | tokenBold tokStyle] ++
+                       ['I' | tokenItalic tokStyle || tokenUnderline tokStyle]
+            in if null fonts
+                  then txt
+                  else literal ("\\f[" <> T.pack fonts <> "]") <>
+                       txt <>
+                       literal "\\f[R]"