Allow dynamic loading of syntax definitions.

See #3334.

* Add writerSyntaxMap to WriterOptions.
* Highlighting: added parameter for SyntaxMap to highlight.
* Implemented --syntax-definition option.

TODO:

[ ] Figure out whether we want to have the xml parsing
    depend on the dtd (it currently does, and fails unless
    the language.dtd is found in the same directory).
[ ] Add an option to read a KDE syntax highlighting theme
    as a custom style.
[ ] Add tests.

6 files changed, 66 insertions, 31 deletions

diff --git a/src/Text/Pandoc/App.hs b/src/Text/Pandoc/App.hs
index ce4c87ec1..5391f0fa6 100644
--- a/src/Text/Pandoc/App.hs
+++ b/src/Text/Pandoc/App.hs
@@ -57,6 +57,8 @@ import qualified Data.Yaml as Yaml
 import Network.URI (URI (..), isURI, parseURI)
 import Paths_pandoc (getDataDir)
 import Skylighting (Style, Syntax (..), defaultSyntaxMap)
+import Skylighting.Parser (missingIncludes, parseSyntaxDefinition,
+                           addSyntaxDefinition)
 import System.Console.GetOpt
 import System.Directory (Permissions (..), doesFileExist, findExecutable,
                          getAppUserDataDirectory, getPermissions)
@@ -299,6 +301,21 @@ convertWithOpts opts = do
                       }
 
   highlightStyle <- lookupHighlightStyle $ optHighlightStyle opts
+  let addSyntaxMap existingmap f = do
+        res <- parseSyntaxDefinition f
+        case res of
+              Left errstr -> err 67 errstr
+              Right syn   -> return $ addSyntaxDefinition syn existingmap
+
+  syntaxMap <- foldM addSyntaxMap defaultSyntaxMap
+                     (optSyntaxDefinitions opts)
+
+  case missingIncludes (M.elems syntaxMap) of
+       [] -> return ()
+       xs -> err 73 $ "Missing syntax definitions:\n" ++
+                unlines (map
+                  (\(syn,dep) -> (T.unpack syn ++ " requires " ++
+                    T.unpack dep ++ " through IncludeRules.")) xs)
 
   let writerOptions = def { writerTemplate         = templ,
                             writerVariables        = variables,
@@ -330,7 +347,8 @@ convertWithOpts opts = do
                             writerEpubChapterLevel = optEpubChapterLevel opts,
                             writerTOCDepth         = optTOCDepth opts,
                             writerReferenceDoc     = optReferenceDoc opts,
-                            writerLaTeXArgs        = optLaTeXEngineArgs opts
+                            writerLaTeXArgs        = optLaTeXEngineArgs opts,
+                            writerSyntaxMap        = syntaxMap
                           }
 
 
@@ -507,6 +525,7 @@ data Opt = Opt
     , optSelfContained         :: Bool    -- ^ Make HTML accessible offline
     , optHtmlQTags             :: Bool    -- ^ Use <q> tags in HTML
     , optHighlightStyle        :: Maybe String -- ^ Style to use for highlighted code
+    , optSyntaxDefinitions     :: [FilePath]  -- ^ xml syntax defs to load
     , optTopLevelDivision      :: TopLevelDivision -- ^ Type of the top-level divisions
     , optHTMLMathMethod        :: HTMLMathMethod -- ^ Method to print HTML math
     , optAbbreviations         :: Maybe FilePath -- ^ Path to abbrevs file
@@ -574,6 +593,7 @@ defaultOpts = Opt
     , optSelfContained         = False
     , optHtmlQTags             = False
     , optHighlightStyle        = Just "pygments"
+    , optSyntaxDefinitions     = []
     , optTopLevelDivision      = TopLevelDefault
     , optHTMLMathMethod        = PlainMath
     , optAbbreviations         = Nothing
@@ -987,6 +1007,13 @@ options =
                  "STYLE")
                  "" -- "Style for highlighted code"
 
+    , Option "" ["syntax-definition"]
+                (ReqArg
+                 (\arg opt -> return opt{ optSyntaxDefinitions = arg :
+                                             optSyntaxDefinitions opt })
+                 "FILE")
+                "" -- "Syntax definition (xml) file"
+
     , Option "H" ["include-in-header"]
                  (ReqArg
                   (\arg opt -> return opt{ optIncludeInHeader =
diff --git a/src/Text/Pandoc/Highlighting.hs b/src/Text/Pandoc/Highlighting.hs
index a4732cd02..f249f96ad 100644
--- a/src/Text/Pandoc/Highlighting.hs
+++ b/src/Text/Pandoc/Highlighting.hs
@@ -76,21 +76,22 @@ languagesByExtension :: String -> [String]
 languagesByExtension ext =
   [T.unpack (T.toLower (sName s)) | s <- syntaxesByExtension defaultSyntaxMap ext]
 
-highlight :: (FormatOptions -> [SourceLine] -> a) -- ^ Formatter
+highlight :: SyntaxMap
+          -> (FormatOptions -> [SourceLine] -> a) -- ^ Formatter
           -> Attr   -- ^ Attributes of the CodeBlock
           -> String -- ^ Raw contents of the CodeBlock
           -> Either String a
-highlight formatter (_, classes, keyvals) rawCode =
+highlight syntaxmap formatter (_, classes, keyvals) rawCode =
   let firstNum = fromMaybe 1 (safeRead (fromMaybe "1" $ lookup "startFrom" keyvals))
       fmtOpts = defaultFormatOpts{
                   startNumber = firstNum,
                   numberLines = any (`elem`
                         ["number","numberLines", "number-lines"]) classes }
-      tokenizeOpts = TokenizerConfig{ syntaxMap = defaultSyntaxMap
+      tokenizeOpts = TokenizerConfig{ syntaxMap = syntaxmap
                                     , traceOutput = False }
       classes' = map T.pack classes
       rawCode' = T.pack rawCode
-  in  case msum (map (\l -> lookupSyntax l defaultSyntaxMap) classes') of
+  in  case msum (map (\l -> lookupSyntax l syntaxmap) classes') of
             Nothing
               | numberLines fmtOpts -> Right
                               $ formatter fmtOpts{ codeClasses = [],
diff --git a/src/Text/Pandoc/Options.hs b/src/Text/Pandoc/Options.hs
index 0379b0ddf..0b09f0497 100644
--- a/src/Text/Pandoc/Options.hs
+++ b/src/Text/Pandoc/Options.hs
@@ -50,6 +50,7 @@ import Data.Default
 import qualified Data.Set as Set
 import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
+import Skylighting (SyntaxMap, defaultSyntaxMap)
 import Text.Pandoc.Extensions
 import Text.Pandoc.Highlighting (Style, pygments)
 
@@ -185,6 +186,7 @@ data WriterOptions = WriterOptions
   , writerReferenceDoc      :: Maybe FilePath -- ^ Path to reference document if specified
   , writerLaTeXArgs         :: [String]       -- ^ Flags to pass to latex-engine
   , writerReferenceLocation :: ReferenceLocation    -- ^ Location of footnotes and references for writing markdown
+  , writerSyntaxMap         :: SyntaxMap
   } deriving (Show, Data, Typeable, Generic)
 
 instance Default WriterOptions where
@@ -220,6 +222,7 @@ instance Default WriterOptions where
                       , writerReferenceDoc     = Nothing
                       , writerLaTeXArgs        = []
                       , writerReferenceLocation = EndOfDocument
+                      , writerSyntaxMap        = defaultSyntaxMap
                       }
 
 -- | Returns True if the given extension is enabled.
diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs
index 5e4fe7731..fcc8551a4 100644
--- a/src/Text/Pandoc/Writers/Docx.hs
+++ b/src/Text/Pandoc/Writers/Docx.hs
@@ -1181,7 +1181,8 @@ inlineToOpenXML' opts (Code attrs str) = do
   withTextProp (rCustomStyle "VerbatimChar")
     $ if isNothing (writerHighlightStyle opts)
           then unhighlighted
-          else case highlight formatOpenXML attrs str of
+          else case highlight (writerSyntaxMap opts)
+                      formatOpenXML attrs str of
                     Right h  -> return h
                     Left msg -> do
                       unless (null msg) $ report $ CouldNotHighlight msg
diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs
index 10b782de7..42726bc61 100644
--- a/src/Text/Pandoc/Writers/HTML.hs
+++ b/src/Text/Pandoc/Writers/HTML.hs
@@ -642,7 +642,7 @@ blockToHtml opts (CodeBlock (id',classes,keyvals) rawCode) = do
                     then unlines . map ("> " ++) . lines $ rawCode
                     else rawCode
       hlCode   = if isJust (writerHighlightStyle opts)
-                    then highlight formatHtmlBlock
+                    then highlight (writerSyntaxMap opts) formatHtmlBlock
                             (id',classes',keyvals) adjCode
                     else Left ""
   case hlCode of
@@ -885,8 +885,9 @@ inlineToHtml opts inline = do
                                return $ addAttrs opts (id',[],keyvals) h
                         where (id',_,keyvals) = attr
                               hlCode = if isJust (writerHighlightStyle opts)
-                                          then highlight formatHtmlInline
-                                                   attr str
+                                          then highlight
+                                                 (writerSyntaxMap opts)
+                                                 formatHtmlInline attr str
                                           else Left ""
     (Strikeout lst)  -> inlineListToHtml opts lst >>=
                         return . H.del
diff --git a/src/Text/Pandoc/Writers/LaTeX.hs b/src/Text/Pandoc/Writers/LaTeX.hs
index 44c00df24..eb38485de 100644
--- a/src/Text/Pandoc/Writers/LaTeX.hs
+++ b/src/Text/Pandoc/Writers/LaTeX.hs
@@ -548,7 +548,8 @@ blockToLaTeX (CodeBlock (identifier,classes,keyvalAttr) str) = do
         return $ flush ("\\begin{lstlisting}" <> printParams $$ text str $$
                  "\\end{lstlisting}") $$ cr
   let highlightedCodeBlock =
-        case highlight formatLaTeXBlock ("",classes,keyvalAttr) str of
+        case highlight (writerSyntaxMap opts)
+                 formatLaTeXBlock ("",classes,keyvalAttr) str of
                Left msg -> do
                  unless (null msg) $
                    report $ CouldNotHighlight msg
@@ -953,32 +954,33 @@ inlineToLaTeX (Cite cits lst) = do
 inlineToLaTeX (Code (_,classes,_) str) = do
   opts <- gets stOptions
   inHeading <- gets stInHeading
+  let listingsCode = do
+        let listingsopt = case getListingsLanguage classes of
+                               Just l -> "[language=" ++ mbBraced l ++ "]"
+                               Nothing -> ""
+        inNote <- gets stInNote
+        when inNote $ modify $ \s -> s{ stVerbInNote = True }
+        let chr = case "!\"&'()*,-./:;?@_" \\ str of
+                       (c:_) -> c
+                       []    -> '!'
+        return $ text $ "\\lstinline" ++ listingsopt ++ [chr] ++ str ++ [chr]
+  let rawCode = liftM (text . (\s -> "\\texttt{" ++ escapeSpaces s ++ "}"))
+                 $ stringToLaTeX CodeString str
+                where escapeSpaces =  concatMap
+                         (\c -> if c == ' ' then "\\ " else [c])
+  let highlightCode = do
+        case highlight (writerSyntaxMap opts)
+                 formatLaTeXInline ("",classes,[]) str of
+               Left msg -> do
+                 unless (null msg) $ report $ CouldNotHighlight msg
+                 rawCode
+               Right h -> modify (\st -> st{ stHighlighting = True }) >>
+                          return (text (T.unpack h))
   case () of
      _ | writerListings opts  && not inHeading      -> listingsCode
        | isJust (writerHighlightStyle opts) && not (null classes)
                                                     -> highlightCode
        | otherwise                                  -> rawCode
-   where listingsCode = do
-           let listingsopt = case getListingsLanguage classes of
-                                  Just l -> "[language=" ++ mbBraced l ++ "]"
-                                  Nothing -> ""
-           inNote <- gets stInNote
-           when inNote $ modify $ \s -> s{ stVerbInNote = True }
-           let chr = case "!\"&'()*,-./:;?@_" \\ str of
-                          (c:_) -> c
-                          []    -> '!'
-           return $ text $ "\\lstinline" ++ listingsopt ++ [chr] ++ str ++ [chr]
-         highlightCode = do
-           case highlight formatLaTeXInline ("",classes,[]) str of
-                  Left msg -> do
-                    unless (null msg) $ report $ CouldNotHighlight msg
-                    rawCode
-                  Right h -> modify (\st -> st{ stHighlighting = True }) >>
-                             return (text (T.unpack h))
-         rawCode = liftM (text . (\s -> "\\texttt{" ++ escapeSpaces s ++ "}"))
-                          $ stringToLaTeX CodeString str
-           where
-             escapeSpaces =  concatMap (\c -> if c == ' ' then "\\ " else [c])
 inlineToLaTeX (Quoted qt lst) = do
   contents <- inlineListToLaTeX lst
   csquotes <- liftM stCsquotes get