LaTeX writer: support beamer overlays (take 2)

src/Text/Pandoc/Writers/LaTeX.hs

@@ -31,6 +31,7 @@ import Control.Monad
  when,
  unless )
 import Data.Containers.ListUtils (nubOrd)
+import Data.Bool (bool)
 import Data.Char (isDigit)
 import Data.List (intersperse, (\\))
 import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe, isNothing)
@@ -275,7 +276,14 @@ isListBlock _ = False
 blockToLaTeX :: PandocMonad m
  => Block -- ^ Block to convert
  -> LW m (Doc Text)
-blockToLaTeX (Div attr@(identifier,"block":dclasses,_)
+blockToLaTeX b = wrapInOverlays (blockAttr b) <*> blockToLaTeX' b
+
+-- Helper function used by blockToLatex
+-- (does not wrap in beamer overlay)
+blockToLaTeX' :: PandocMonad m
+ => Block -- ^ Block to convert
+ -> LW m (Doc Text)
+blockToLaTeX' (Div attr@(identifier,"block":dclasses,_)
  (Header _ _ ils : bs)) = do
  let blockname
  | "example" `elem` dclasses = "exampleblock"
@@ -288,7 +296,7 @@ blockToLaTeX (Div attr@(identifier,"block":dclasses,_)
  contents <- blockListToLaTeX bs
  wrapDiv attr $ ("\\begin" <> braces blockname <> braces title' <> anchor) $$
  contents $$ "\\end" <> braces blockname
-blockToLaTeX (Div (identifier,"slide":dclasses,dkvs)
+blockToLaTeX' (Div (identifier,"slide":dclasses,dkvs)
  (Header _ (_,hclasses,hkvs) ils : bs)) = do
  -- note: [fragile] is required or verbatim breaks
  let hasCodeBlock (CodeBlock _ _) = [True]
@@ -322,12 +330,12 @@ blockToLaTeX (Div (identifier,"slide":dclasses,dkvs)
  contents <- blockListToLaTeX bs >>= wrapDiv (identifier,classes,kvs)
  return $ ("\\begin{frame}" <> options <> slideTitle <> slideAnchor) $$
  contents $$ "\\end{frame}"
-blockToLaTeX (Div (identifier@(T.uncons -> Just (_,_)),dclasses,dkvs)
+blockToLaTeX' (Div (identifier@(T.uncons -> Just (_,_)),dclasses,dkvs)
  (Header lvl ("",hclasses,hkvs) ils : bs)) =
  -- move identifier from div to header
  blockToLaTeX (Div ("",dclasses,dkvs)
  (Header lvl (identifier,hclasses,hkvs) ils : bs))
-blockToLaTeX (Div (identifier,classes,kvs) bs) = do
+blockToLaTeX' (Div (identifier,classes,kvs) bs) = do
  beamer <- gets stBeamer
  oldIncremental <- gets stIncremental
  if beamer && "incremental" `elem` classes
@@ -362,19 +370,19 @@ blockToLaTeX (Div (identifier,classes,kvs) bs) = do
  linkAnchor <- hypertarget identifier
  pure $ linkAnchor $$ txt
  wrapDiv (identifier,classes,kvs) result >>= wrap
-blockToLaTeX (Plain lst) =
+blockToLaTeX' (Plain lst) =
  inlineListToLaTeX lst
 -- . . . indicates pause in beamer slides
-blockToLaTeX (Para [Str ".",Space,Str ".",Space,Str "."]) = do
+blockToLaTeX' (Para [Str ".",Space,Str ".",Space,Str "."]) = do
  beamer <- gets stBeamer
  if beamer
  then blockToLaTeX (RawBlock "latex" "\\pause")
  else inlineListToLaTeX [Str ".",Space,Str ".",Space,Str "."]
-blockToLaTeX (Para lst) =
+blockToLaTeX' (Para lst) =
  inlineListToLaTeX lst
-blockToLaTeX (LineBlock lns) =
+blockToLaTeX' (LineBlock lns) =
  blockToLaTeX $ linesToPara lns
-blockToLaTeX (BlockQuote lst) = do
+blockToLaTeX' (BlockQuote lst) = do
  beamer <- gets stBeamer
  case lst of
  [b] | beamer && isListBlock b -> do
@@ -389,7 +397,7 @@ blockToLaTeX (BlockQuote lst) = do
  contents <- blockListToLaTeX lst
  modify (\s -> s{stInQuote = oldInQuote})
  return $ "\\begin{quote}" $$ contents $$ "\\end{quote}"
-blockToLaTeX (CodeBlock (identifier,classes,keyvalAttr) str) = do
+blockToLaTeX' (CodeBlock (identifier,classes,keyvalAttr) str) = do
  opts <- gets stOptions
  inNote <- stInNote <$> get
  linkAnchor <- if T.null identifier
@@ -458,16 +466,16 @@ blockToLaTeX (CodeBlock (identifier,classes,keyvalAttr) str) = do
  | not inNote
  , "\\end{verbatim}" `T.isInfixOf` str -> highlightedCodeBlock
  | otherwise -> rawCodeBlock
-blockToLaTeX b@(RawBlock f x) = do
+blockToLaTeX' b@(RawBlock f x) = do
  beamer <- gets stBeamer
  if f == Format "latex" || f == Format "tex" ||
  (f == Format "beamer" && beamer)
  then return $ literal x
  else do
  report $ BlockNotRendered b
  return empty
-blockToLaTeX (BulletList []) = return empty -- otherwise latex error
-blockToLaTeX (BulletList lst) = do
+blockToLaTeX' (BulletList []) = return empty -- otherwise latex error
+blockToLaTeX' (BulletList lst) = do
  incremental <- gets stIncremental
  isFirstInDefinition <- gets stIsFirstInDefinition
  beamer <- gets stBeamer
@@ -482,8 +490,8 @@ blockToLaTeX (BulletList lst) = do
  (if isFirstInDefinition then "\\item[]" else mempty) $$
  vcat items $$
  "\\end{itemize}"
-blockToLaTeX (OrderedList _ []) = return empty -- otherwise latex error
-blockToLaTeX (OrderedList (start, numstyle, numdelim) lst) = do
+blockToLaTeX' (OrderedList _ []) = return empty -- otherwise latex error
+blockToLaTeX' (OrderedList (start, numstyle, numdelim) lst) = do
  st <- get
  let inc = if stBeamer st && stIncremental st then "[<+->]" else ""
  let oldlevel = stOLLevel st
@@ -535,8 +543,8 @@ blockToLaTeX (OrderedList (start, numstyle, numdelim) lst) = do
  $$ (if isFirstInDefinition then "\\item[]" else mempty)
  $$ vcat items
  $$ "\\end{enumerate}"
-blockToLaTeX (DefinitionList []) = return empty
-blockToLaTeX (DefinitionList lst) = do
+blockToLaTeX' (DefinitionList []) = return empty
+blockToLaTeX' (DefinitionList lst) = do
  incremental <- gets stIncremental
  beamer <- gets stBeamer
  let inc = if beamer && incremental then "[<+->]" else ""
@@ -546,18 +554,18 @@ blockToLaTeX (DefinitionList lst) = do
  else empty
  return $ text ("\\begin{description}" <> inc) $$ spacing $$ vcat items $$
  "\\end{description}"
-blockToLaTeX HorizontalRule =
+blockToLaTeX' HorizontalRule =
  return
  "\\begin{center}\\rule{0.5\\linewidth}{0.5pt}\\end{center}"
-blockToLaTeX (Header level (id',classes,_) lst) = do
+blockToLaTeX' (Header level (id',classes,_) lst) = do
  modify $ \s -> s{stInHeading = True}
  hdr <- sectionHeader classes id' level lst
  modify $ \s -> s{stInHeading = False}
  return hdr
-blockToLaTeX (Table attr blkCapt specs thead tbodies tfoot) =
+blockToLaTeX' (Table attr blkCapt specs thead tbodies tfoot) =
  tableToLaTeX inlineListToLaTeX blockListToLaTeX
  (Ann.toTable attr blkCapt specs thead tbodies tfoot)
-blockToLaTeX (Figure (ident, _, _) captnode body) = do
+blockToLaTeX' (Figure (ident, _, _) captnode body) = do
  (capt, captForLof, footnotes) <- getCaption inlineListToLaTeX True captnode
  lab <- labelFor ident
  let caption = "\\caption" <> captForLof <> braces capt <> lab
@@ -762,10 +770,18 @@ inlineListToLaTeX lst = hcat <$>
 inlineToLaTeX :: PandocMonad m
  => Inline -- ^ Inline to convert
  -> LW m (Doc Text)
-inlineToLaTeX (Span ("",["mark"],[]) lst) = do
+inlineToLaTeX i = wrapInOverlays (inlineAttr i) <*> inlineToLaTeX' i
+
+-- Helper function used by inlineToLaTeX
+-- (does not wrap in beamer overlay)
+inlineToLaTeX' :: PandocMonad m
+ => Inline -- ^ Inline to convert
+ -> LW m (Doc Text)
+
+inlineToLaTeX' (Span ("",["mark"],[]) lst) = do
  modify $ \st -> st{ stStrikeout = True } -- this gives us the soul package
  inCmd "hl" <$> inlineListToLaTeX lst
-inlineToLaTeX (Span (id',classes,kvs) ils) = do
+inlineToLaTeX' (Span (id',classes,kvs) ils) = do
  linkAnchor <- hypertarget id'
  lang <- toLang $ lookup "lang" kvs
  let classToCmd "csl-no-emph" = Just "textup"
@@ -799,26 +815,26 @@ inlineToLaTeX (Span (id',classes,kvs) ils) = do
  (if null cmds
  then braces contents
  else foldr inCmd contents cmds)
-inlineToLaTeX (Emph lst) = inCmd "emph" <$> inlineListToLaTeX lst
-inlineToLaTeX (Underline lst) = do
+inlineToLaTeX' (Emph lst) = inCmd "emph" <$> inlineListToLaTeX lst
+inlineToLaTeX' (Underline lst) = do
  modify $ \st -> st{ stStrikeout = True } -- this gives us the soul package
  inCmd "ul" <$> inlineListToLaTeX lst
-inlineToLaTeX (Strong lst) = inCmd "textbf" <$> inlineListToLaTeX lst
-inlineToLaTeX (Strikeout lst) = do
+inlineToLaTeX' (Strong lst) = inCmd "textbf" <$> inlineListToLaTeX lst
+inlineToLaTeX' (Strikeout lst) = do
  -- we need to protect VERB in an mbox or we get an error
  -- see #1294
  -- with regular texttt we don't get an error, but we get
  -- incorrect results if there is a space, see #5529
  contents <- inlineListToLaTeX $ walk (concatMap protectCode) lst
  modify $ \s -> s{ stStrikeout = True }
  return $ inCmd "st" contents
-inlineToLaTeX (Superscript lst) =
+inlineToLaTeX' (Superscript lst) =
  inCmd "textsuperscript" <$> inlineListToLaTeX lst
-inlineToLaTeX (Subscript lst) =
+inlineToLaTeX' (Subscript lst) =
  inCmd "textsubscript" <$> inlineListToLaTeX lst
-inlineToLaTeX (SmallCaps lst) =
+inlineToLaTeX' (SmallCaps lst) =
  inCmd "textsc"<$> inlineListToLaTeX lst
-inlineToLaTeX (Cite cits lst) = do
+inlineToLaTeX' (Cite cits lst) = do
  opts <- gets stOptions
  modify $ \st -> st{ stInCite = True }
  res <- case writerCiteMethod opts of
@@ -828,7 +844,7 @@ inlineToLaTeX (Cite cits lst) = do
  modify $ \st -> st{ stInCite = False }
  pure res
 
-inlineToLaTeX (Code (_,classes,kvs) str) = do
+inlineToLaTeX' (Code (_,classes,kvs) str) = do
  opts <- gets stOptions
  inHeading <- gets stInHeading
  inItem <- gets stInItem
@@ -886,7 +902,7 @@ inlineToLaTeX (Code (_,classes,kvs) str) = do
  | isJust (writerHighlightStyle opts) && not (null classes)
  -> highlightCode
  | otherwise -> rawCode
-inlineToLaTeX (Quoted qt lst) = do
+inlineToLaTeX' (Quoted qt lst) = do
  contents <- inlineListToLaTeX lst
  csquotes <- liftM stCsquotes get
  opts <- gets stOptions
@@ -915,16 +931,16 @@ inlineToLaTeX (Quoted qt lst) = do
  isQuoted (Span _ (x:_)) = isQuoted x
  isQuoted (Quoted _ _) = True
  isQuoted _ = False
-inlineToLaTeX (Str str) = do
+inlineToLaTeX' (Str str) = do
  setEmptyLine False
  liftM literal $ stringToLaTeX TextString str
-inlineToLaTeX (Math InlineMath str) = do
+inlineToLaTeX' (Math InlineMath str) = do
  setEmptyLine False
  return $ "\\(" <> literal (handleMathComment str) <> "\\)"
-inlineToLaTeX (Math DisplayMath str) = do
+inlineToLaTeX' (Math DisplayMath str) = do
  setEmptyLine False
  return $ "\\[" <> literal (handleMathComment str) <> "\\]"
-inlineToLaTeX il@(RawInline f str) = do
+inlineToLaTeX' il@(RawInline f str) = do
  beamer <- gets stBeamer
  if f == Format "latex" || f == Format "tex" ||
  (f == Format "beamer" && beamer)
@@ -934,18 +950,18 @@ inlineToLaTeX il@(RawInline f str) = do
  else do
  report $ InlineNotRendered il
  return empty
-inlineToLaTeX LineBreak = do
+inlineToLaTeX' LineBreak = do
  emptyLine <- gets stEmptyLine
  setEmptyLine True
  return $ (if emptyLine then "\\strut " else "") <> "\\\\" <> cr
-inlineToLaTeX SoftBreak = do
+inlineToLaTeX' SoftBreak = do
  wrapText <- gets (writerWrapText . stOptions)
  case wrapText of
  WrapAuto -> return space
  WrapNone -> return space
  WrapPreserve -> return cr
-inlineToLaTeX Space = return space
-inlineToLaTeX (Link (id',_,_) txt (src,_)) =
+inlineToLaTeX' Space = return space
+inlineToLaTeX' (Link (id',_,_) txt (src,_)) =
  (case T.uncons src of
  Just ('#', ident) -> do
  contents <- inlineListToLaTeX txt
@@ -979,11 +995,11 @@ inlineToLaTeX (Link (id',_,_) txt (src,_)) =
  else \x -> do
  linkAnchor <- hypertarget id'
  return (linkAnchor <> x))
-inlineToLaTeX il@(Image _ _ (src, _))
+inlineToLaTeX' il@(Image _ _ (src, _))
  | Just _ <- T.stripPrefix "data:" src = do
  report $ InlineNotRendered il
  return empty
-inlineToLaTeX (Image attr@(_,_,kvs) _ (source, _)) = do
+inlineToLaTeX' (Image attr@(_,_,kvs) _ (source, _)) = do
  setEmptyLine False
  let isSVG = ".svg" `T.isSuffixOf` source || ".SVG" `T.isSuffixOf` source
  modify $ \s -> s{ stGraphics = True
@@ -1024,7 +1040,7 @@ inlineToLaTeX (Image attr@(_,_,kvs) _ (source, _)) = do
  (if inHeading then "\\protect" else "") <>
  (if isSVG then "\\includesvg" else "\\includegraphics") <>
  options <> braces (literal source'')
-inlineToLaTeX (Note contents) = do
+inlineToLaTeX' (Note contents) = do
  setEmptyLine False
  externalNotes <- gets stExternalNotes
  modify (\s -> s{stInNote = True, stExternalNotes = True})
@@ -1081,3 +1097,42 @@ extractInline _ _ = []
 -- Look up a key in an attribute and give a list of its values
 lookKey :: Text -> Attr -> [Text]
 lookKey key (_,_,kvs) = maybe [] T.words $ lookup key kvs
+
+-- Get the top-level attributes of block elements
+blockAttr :: Block -> Attr
+blockAttr (CodeBlock a _) = a
+blockAttr (Header _ a _) = a
+blockAttr (Table a _ _ _ _ _) = a
+blockAttr (Figure a _ _) = a
+blockAttr (Div a _) = a
+blockAttr _ = mempty -- other blocks carry no 'Attr' at the top level
+
+-- Get the top-level attributes of inline elements
+inlineAttr :: Inline -> Attr
+inlineAttr (Code a _) = a
+inlineAttr (Link a _ _) = a
+inlineAttr (Image a _ _) = a
+inlineAttr (Span a _) = a
+inlineAttr _ = mempty -- other inlines carry no 'Attr' at the top level
+
+-- Given an element's attributes, wrap its generated LaTeX
+-- in beamer overlay environments,
+-- one environment per attribute requesting an overlay
+wrapInOverlays' :: Attr -> Doc Text -> Doc Text
+wrapInOverlays' (_,_,kvs) doc =
+ foldr -- earlier overlays go outside later ones
+ (\(envtype,overlay) latex -> mconcat
+ [ "\\begin{",literal envtype,"env}<",literal overlay,">"
+ , latex
+ , "\\end{",literal envtype,"env}"
+ ])
+ doc
+ -- Not all attributes generate overlays
+ (filter ((`elem` ["only","visible","uncover","invisible"]) . fst) kvs)
+-- The list of beamer overlay environments comes from the beamer 3.70 user guide,
+-- https://mirrors.rit.edu/CTAN/macros/latex/contrib/beamer/doc/beameruserguide.pdf#page=83
+-- altenv is not supported since it takes arguments 
+
+-- Like wrapInOverlays', but does nothing ouside beamer-mode
+wrapInOverlays :: PandocMonad m => Attr -> LW m (Doc Text -> Doc Text)
+wrapInOverlays a = bool id (wrapInOverlays' a) <$> gets stBeamer

test/Tests/Writers/LaTeX.hs

@@ -12,6 +12,9 @@ import Text.Pandoc.Builder
 latex :: (ToPandoc a) => a -> String
 latex = latexWithOpts def
 
+beamer :: (ToPandoc a) => a -> String
+beamer = beamerWithOpts def
+
 latexListing :: (ToPandoc a) => a -> String
 latexListing = latexWithOpts def{ writerListings = True }
 
@@ -174,4 +177,24 @@ tests = [ testGroup "code blocks"
  ]
  ]
  ]
+ , testGroup "beamer overlays"
+ [ test beamer "code block" $ codeBlockWith ("",[],[("only","2")]) "hi" =?>
+ unlines
+ [ "\\begin{frame}[fragile]"
+ , "\\begin{onlyenv}<2>\\begin{verbatim}"
+ , "hi"
+ , "\\end{verbatim}"
+ , "\\end{onlyenv}"
+ , "\\end{frame}"
+ ]
+ , test beamer "code block, nested overlays" $ codeBlockWith ("",[],[("only","1-3"),("invisible","2")]) "hi" =?>
+ unlines
+ [ "\\begin{frame}[fragile]"
+ , "\\begin{onlyenv}<1-3>\\begin{invisibleenv}<2>\\begin{verbatim}"
+ , "hi"
+ , "\\end{verbatim}"
+ , "\\end{invisibleenv}\\end{onlyenv}"
+ , "\\end{frame}"
+ ]
+ ]
  ]