Add highlight directive to the rST reader (#6140)

src/Text/Pandoc/Parsing.hs

@@ -1138,6 +1138,7 @@ data ParserState = ParserState
       stateExamples          :: M.Map Text Int, -- ^ Map from example labels to numbers
       stateMacros            :: M.Map Text Macro, -- ^ Table of macros defined so far
       stateRstDefaultRole    :: Text,        -- ^ Current rST default interpreted text role
+      stateRstHighlight      :: Maybe Text,  -- ^ Current rST literal block language
       stateRstCustomRoles    :: M.Map Text (Text, Maybe Text, Attr), -- ^ Current rST custom text roles
       -- Triple represents: 1) Base role, 2) Optional format (only for :raw:
       -- roles), 3) Additional classes (rest of Attr is unused)).
@@ -1248,6 +1249,7 @@ defaultParserState =
                   stateExamples        = M.empty,
                   stateMacros          = M.empty,
                   stateRstDefaultRole  = "title-reference",
+                  stateRstHighlight    = Nothing,
                   stateRstCustomRoles  = M.empty,
                   stateCaption         = Nothing,
                   stateInHtmlBlock     = Nothing,

src/Text/Pandoc/Readers/RST.hs

@@ -23,7 +23,7 @@ import Control.Monad.Identity (Identity (..))
 import Data.Char (isHexDigit, isSpace, toUpper, isAlphaNum)
 import Data.List (deleteFirstsBy, elemIndex, nub, sort, transpose)
 import qualified Data.Map as M
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, maybeToList)
 import Data.Sequence (ViewR (..), viewr)
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -390,11 +390,13 @@ quotedBlock = try $ do
 codeBlockStart :: Monad m => ParserT Text st m Char
 codeBlockStart = string "::" >> blankline >> blankline
 
-codeBlock :: (HasReaderOptions st, Monad m) => ParserT Text st m Blocks
+codeBlock :: Monad m => ParserT Text ParserState m Blocks
 codeBlock = try $ codeBlockStart >> codeBlockBody
 
-codeBlockBody :: (HasReaderOptions st, Monad m) => ParserT Text st m Blocks
-codeBlockBody = try $ B.codeBlock . stripTrailingNewlines <$>
+codeBlockBody :: Monad m => ParserT Text ParserState m Blocks
+codeBlockBody = do
+  lang <- stateRstHighlight <$> getState
+  try $ B.codeBlockWith ("", maybeToList lang, []) . stripTrailingNewlines <$>
                 (indentedBlock <|> quotedBlock)
 
 lhsCodeBlock :: Monad m => RSTParser m Blocks
@@ -716,6 +718,11 @@ directive' = do
                                   case trim top of
                                      ""   -> stateRstDefaultRole def
                                      role -> role })
+        "highlight" -> mempty <$ updateState (\s ->
+                              s { stateRstHighlight =
+                                  case trim top of
+                                     ""   -> stateRstHighlight def
+                                     lang -> Just lang })
         x | x == "code" || x == "code-block" || x == "sourcecode" ->
           codeblock name classes
                     (lookup "number-lines" fields) (trim top) body True

test/rst-reader.native

@@ -39,6 +39,10 @@ Pandoc (Meta {unMeta = fromList [("author",MetaList [MetaInlines [Str "John",Spa
 ,CodeBlock ("",[],[]) "this block is indented by two tabs\n\nThese should not be escaped:  \\$ \\\\ \\> \\[ \\{"
 ,Para [Str "And:"]
 ,CodeBlock ("",["python"],[]) "def my_function(x):\n    return x + 1"
+,Para [Str "If",Space,Str "we",Space,Str "use",Space,Str "the",Space,Str "highlight",Space,Str "directive,",Space,Str "we",Space,Str "can",Space,Str "specify",Space,Str "a",Space,Str "default",Space,Str "language",SoftBreak,Str "for",Space,Str "literate",Space,Str "blocks."]
+,CodeBlock ("",["haskell"],[]) "-- this code is in haskell\ndata Tree = Leaf | Node Tree Tree"
+,CodeBlock ("",["haskell"],[]) "-- this code is in haskell too\ndata Nat = Zero | Succ Nat"
+,CodeBlock ("",["javascript"],[]) "-- this code is in javascript\nlet f = (x, y) => x + y"
 ,Header 1 ("lists",[],[]) [Str "Lists"]
 ,Header 2 ("unordered",[],[]) [Str "Unordered"]
 ,Para [Str "Asterisks",Space,Str "tight:"]

test/rst-reader.rst

@@ -107,6 +107,30 @@ And:
    def my_function(x):
        return x + 1
 
+If we use the highlight directive, we can specify a default language
+for literate blocks.
+
+.. highlight:: haskell
+
+::
+
+  -- this code is in haskell
+  data Tree = Leaf | Node Tree Tree
+
+::
+
+  -- this code is in haskell too
+  data Nat = Zero | Succ Nat
+
+.. highlight:: javascript
+
+::
+
+  -- this code is in javascript
+  let f = (x, y) => x + y
+
+.. highlight::
+
 Lists
 =====