Powerpoint writer: Implement syntax highlighting

This also necessitated implementing colors and underlining, though
there is currently no way to produce these from markdown. Note that
background colors can't be implemented in PowerPoint, so highlighting
styles that require these will be incomplete.

2 files changed, 82 insertions, 24 deletions

diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs
index f0485adcc..d30819d47 100644
--- a/src/Text/Pandoc/Writers/Powerpoint/Output.hs
+++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs
@@ -38,6 +38,7 @@ import Control.Monad.Except (throwError, catchError)
 import Control.Monad.Reader
 import Control.Monad.State
 import Codec.Archive.Zip
+import Data.Char (toUpper)
 import Data.List (intercalate, stripPrefix, nub, union, isPrefixOf)
 import Data.Default
 import Text.Pandoc.Compat.Time (formatTime, defaultTimeLocale)
@@ -62,6 +63,7 @@ import System.FilePath.Glob
 import Text.TeXMath
 import Text.Pandoc.Writers.Math (convertMath)
 import Text.Pandoc.Writers.Powerpoint.Presentation
+import Skylighting (fromColor)
 
 -- This populates the global ids map with images already in the
 -- template, so the ids won't be used by images introduced by the
@@ -703,26 +705,28 @@ paraElemToElement Break = return $ mknode "a:br" [] ()
 paraElemToElement (Run rpr s) = do
   let sizeAttrs = case rPropForceSize rpr of
                     Just n -> [("sz", (show $ n * 100))]
-                    Nothing -> []
+                    Nothing -> if rPropCode rpr
+                               -- hardcoded size for code for now
+                               then [("sz", "1800")]
+                               else []
       attrs = sizeAttrs ++
-        if rPropCode rpr
-        then []
-        else (if rPropBold rpr then [("b", "1")] else []) ++
-             (if rPropItalics rpr then [("i", "1")] else []) ++
-             (case rStrikethrough rpr of
-                Just NoStrike     -> [("strike", "noStrike")]
-                Just SingleStrike -> [("strike", "sngStrike")]
-                Just DoubleStrike -> [("strike", "dblStrike")]
-                Nothing -> []) ++
-             (case rBaseline rpr of
-                Just n -> [("baseline", show n)]
-                Nothing -> []) ++
-             (case rCap rpr of
-                Just NoCapitals -> [("cap", "none")]
-                Just SmallCapitals -> [("cap", "small")]
-                Just AllCapitals -> [("cap", "all")]
-                Nothing -> []) ++
-             []
+        (if rPropBold rpr then [("b", "1")] else []) ++
+        (if rPropItalics rpr then [("i", "1")] else []) ++
+        (if rPropUnderline rpr then [("u", "sng")] else []) ++
+        (case rStrikethrough rpr of
+            Just NoStrike     -> [("strike", "noStrike")]
+            Just SingleStrike -> [("strike", "sngStrike")]
+            Just DoubleStrike -> [("strike", "dblStrike")]
+            Nothing -> []) ++
+        (case rBaseline rpr of
+            Just n -> [("baseline", show n)]
+            Nothing -> []) ++
+        (case rCap rpr of
+            Just NoCapitals -> [("cap", "none")]
+            Just SmallCapitals -> [("cap", "small")]
+            Just AllCapitals -> [("cap", "all")]
+            Nothing -> []) ++
+        []
   linkProps <- case rLink rpr of
                  Just link -> do
                    idNum <- registerLink link
@@ -743,10 +747,19 @@ paraElemToElement (Run rpr s) = do
                              ]
                        in [mknode "a:hlinkClick" linkAttrs ()]
                  Nothing -> return []
-  let propContents = if rPropCode rpr
+  let colorContents = case rSolidFill rpr of
+                        Just color ->
+                          case fromColor color of
+                            '#':hx ->  [mknode "a:solidFill" []
+                                        [mknode "a:srgbClr" [("val", map toUpper hx)] ()]
+                                       ]
+                            _ -> []
+                        Nothing -> []
+  let codeContents = if rPropCode rpr
                      then [mknode "a:latin" [("typeface", "Courier")] ()]
-                     else linkProps
-  return $ mknode "a:r" [] [ mknode "a:rPr" attrs propContents
+                     else []
+  let propContents = linkProps ++ colorContents ++ codeContents
+  return $ mknode "a:r" [] [ mknode "a:rPr" attrs $ propContents
                            , mknode "a:t" [] s
                            ]
 paraElemToElement (MathElem mathType texStr) = do
diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
index e1192745f..f5f7d850f 100644
--- a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
+++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
@@ -73,6 +73,10 @@ import Text.Pandoc.Writers.Shared (metaValueToInlines)
 import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.Maybe (maybeToList)
+import Text.Pandoc.Highlighting
+import qualified Data.Text as T
+import Control.Applicative ((<|>))
+import Skylighting
 
 data WriterEnv = WriterEnv { envMetadata :: Meta
                            , envRunProps :: RunProps
@@ -280,6 +284,10 @@ data RunProps = RunProps { rPropBold :: Bool
                          , rPropCode :: Bool
                          , rPropBlockQuote :: Bool
                          , rPropForceSize :: Maybe Pixels
+                         , rSolidFill :: Maybe Color
+                         -- TODO: Make a full underline data type with
+                         -- the different options.
+                         , rPropUnderline :: Bool
                          } deriving (Show, Eq)
 
 instance Default RunProps where
@@ -292,6 +300,8 @@ instance Default RunProps where
                  , rPropCode = False
                  , rPropBlockQuote = False
                  , rPropForceSize = Nothing
+                 , rSolidFill = Nothing
+                 , rPropUnderline = False
                  }
 
 data PicProps = PicProps { picPropLink :: Maybe LinkTarget
@@ -391,8 +401,17 @@ blockToParagraphs (LineBlock ilsList) = do
   return [Paragraph pProps parElems]
 -- TODO: work out the attributes
 blockToParagraphs (CodeBlock attr str) =
-  local (\r -> r{envParaProps = def{pPropMarginLeft = Just 100}}) $
-  blockToParagraphs $ Para [Code attr str]
+  local (\r -> r{ envParaProps = def{pPropMarginLeft = Just 100}
+                , envRunProps = (envRunProps r){rPropCode = True}}) $ do
+  mbSty <- writerHighlightStyle <$> asks envOpts
+  synMap <- writerSyntaxMap <$> asks envOpts
+  case mbSty of
+    Just sty ->
+      case highlight synMap (formatSourceLines sty) attr str of
+        Right pElems -> do pProps <- asks envParaProps
+                           return $ [Paragraph pProps pElems]
+        Left _ -> blockToParagraphs $ Para [Str str]
+    Nothing -> blockToParagraphs $ Para [Str str]
 -- We can't yet do incremental lists, but we should render a
 -- (BlockQuote List) as a list to maintain compatibility with other
 -- formats.
@@ -878,3 +897,29 @@ documentToPresentation opts (Pandoc meta blks) =
       docProps = metaToDocProps meta
   in
     (Presentation docProps presSlides, msgs)
+
+-- --------------------------------------------------------------
+
+applyTokStyToRunProps :: TokenStyle -> RunProps -> RunProps
+applyTokStyToRunProps tokSty rProps =
+  rProps{ rSolidFill     = tokenColor tokSty <|> rSolidFill rProps
+        , rPropBold      = tokenBold tokSty || rPropBold rProps
+        , rPropItalics   = tokenItalic tokSty || rPropItalics rProps
+        , rPropUnderline = tokenUnderline tokSty || rPropUnderline rProps
+        }
+
+formatToken :: Style -> Token -> ParaElem
+formatToken sty (tokType, txt) =
+  let rProps = def{rPropCode = True, rSolidFill = defaultColor sty}
+      rProps' = case M.lookup tokType (tokenStyles sty) of
+        Just tokSty -> applyTokStyToRunProps tokSty rProps
+        Nothing     -> rProps
+  in
+    Run rProps' $ T.unpack txt
+
+formatSourceLine :: Style -> FormatOptions -> SourceLine -> [ParaElem]
+formatSourceLine sty _ srcLn = map (formatToken sty) srcLn
+
+formatSourceLines :: Style -> FormatOptions -> [SourceLine] -> [ParaElem]
+formatSourceLines sty opts srcLns = intercalate [Break] $
+                                    map (formatSourceLine sty opts) srcLns