pandoc-3.11: src/Text/Pandoc/Writers/OpenDocument.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{- |
Module : Text.Pandoc.Writers.OpenDocument
Copyright : Copyright (C) 2008-2020 Andrea Rossato and John MacFarlane
License : GNU GPL, version 2 or above
Maintainer : Andrea Rossato <andrea.rossato@ing.unitn.it>
Stability : alpha
Portability : portable
Conversion of 'Pandoc' documents to OpenDocument XML.
-}
module Text.Pandoc.Writers.OpenDocument ( writeOpenDocument ) where
import Control.Arrow ((***), (>>>))
import Control.Monad (unless, liftM)
import Control.Monad.State.Strict ( StateT(..), modify, gets, lift )
import Data.Char (chr, isDigit)
import Data.Foldable (find)
import Data.List (sortOn, sortBy)
import qualified Data.List as L
import qualified Data.Map as Map
import Data.Ord (comparing, Down (Down))
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Text.Collate.Lang (Lang (..), parseLang)
import Text.Pandoc.Class.PandocMonad (PandocMonad, report)
import Text.Pandoc.Translations (translateTerm)
import Text.Pandoc.Definition
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Logging
import Text.Pandoc.Options
import Text.DocLayout hiding (link)
import Text.Pandoc.Shared (linesToPara, tshow, blocksToInlines)
import Text.Pandoc.Templates (renderTemplate)
import qualified Text.Pandoc.Translations as Term (Term(Figure, Table))
import Text.Pandoc.Walk
import Text.Pandoc.Writers.Math
import Text.Pandoc.Writers.Shared
import qualified Text.Pandoc.Writers.AnnotatedTable as Ann
import Text.Pandoc.XML
import Text.Printf (printf)
import Text.Pandoc.Highlighting (highlight)
import Skylighting (FormatOptions(..), SourceLine, Token)
-- | Auxiliary function to convert Plain block to Para.
plainToPara :: Block -> Block
plainToPara (Plain x) = Para x
plainToPara x = x
-- Names of predefined styles in the reference.odt; see data/odt/styles.xml.
defaultBulletListStyleName, defaultNumberedListStyleName :: Text
defaultBulletListStyleName = "List_20_1"
defaultNumberedListStyleName = "Numbering_20_1"
bulletItemStyleName, bulletItemTightStyleName,
numberItemStyleName, numberItemTightStyleName :: Text
bulletItemStyleName = "List_20_Bullet"
bulletItemTightStyleName = "List_20_Bullet_20_Tight"
numberItemStyleName = "List_20_Number"
numberItemTightStyleName = "List_20_Number_20_Tight"
-- | Predefined inline style names for single-style spans.
wellKnownTextStyle :: Set.Set TextStyle -> Maybe Text
wellKnownTextStyle s = case Set.toList s of
[Italic] -> Just "Emphasis"
[Bold] -> Just "Strong_20_Emphasis"
[Strike] -> Just "Strikeout"
[Sub] -> Just "Subscript"
[Sup] -> Just "Superscript"
[Pre] -> Just "Source_20_Text"
_ -> Nothing
--
-- OpenDocument writer
--
type OD m = StateT WriterState m
data ReferenceType
= HeaderRef
| TableRef
| FigureRef
data Direction = LTR | RTL
deriving (Show, Eq, Ord)
data WriterState =
WriterState { stNotes :: [Doc Text]
, stTableStyles :: [Doc Text]
, stParaStyles :: [Doc Text]
, stListOverrides :: Map.Map (ListNumberStyle,ListNumberDelim)
(Text, Doc Text)
, stTextStyles :: Map.Map (Set.Set TextStyle)
(Text, Doc Text)
, stTextStyleAttr :: Set.Set TextStyle
, stIndentPara :: Int
, stInDefinition :: Bool
, stTight :: Bool
, stFirstPara :: Bool
, stImageId :: Int
, stTableCaptionId :: Int
, stImageCaptionId :: Int
, stIdentTypes :: [(Text,ReferenceType)]
, stDirection :: Maybe Direction
-- ^ active writing mode
, stDirStyles :: Map.Map (Text, Direction) Text
-- ^ cache of direction-adjusted paragraph styles,
-- keyed on (parent style, writing mode)
}
defaultWriterState :: WriterState
defaultWriterState =
WriterState { stNotes = []
, stTableStyles = []
, stParaStyles = []
, stListOverrides = Map.empty
, stTextStyles = Map.empty
, stTextStyleAttr = Set.empty
, stIndentPara = 0
, stInDefinition = False
, stTight = False
, stFirstPara = False
, stImageId = 1
, stTableCaptionId = 1
, stImageCaptionId = 1
, stIdentTypes = []
, stDirection = Nothing
, stDirStyles = Map.empty
}
when :: Bool -> Doc Text -> Doc Text
when p a = if p then a else empty
addTableStyle :: PandocMonad m => Doc Text -> OD m ()
addTableStyle i = modify $ \s -> s { stTableStyles = i : stTableStyles s }
addNote :: PandocMonad m => Doc Text -> OD m ()
addNote i = modify $ \s -> s { stNotes = i : stNotes s }
addParaStyle :: PandocMonad m => Doc Text -> OD m ()
addParaStyle i = modify $ \s -> s { stParaStyles = i : stParaStyles s }
addTextStyle :: PandocMonad m
=> Set.Set TextStyle -> (Text, Doc Text) -> OD m ()
addTextStyle attrs i = modify $ \s ->
s { stTextStyles = Map.insert attrs i (stTextStyles s) }
increaseIndent :: PandocMonad m => OD m ()
increaseIndent = modify $ \s -> s { stIndentPara = 1 + stIndentPara s }
resetIndent :: PandocMonad m => OD m ()
resetIndent = modify $ \s -> s { stIndentPara = stIndentPara s - 1 }
setInDefinitionList :: PandocMonad m => Bool -> OD m ()
setInDefinitionList b = modify $ \s -> s { stInDefinition = b }
setFirstPara :: PandocMonad m => OD m ()
setFirstPara = modify $ \s -> s { stFirstPara = True }
inParagraphTags :: PandocMonad m => Doc Text -> OD m (Doc Text)
inParagraphTags d = do
b <- gets stFirstPara
sty <- if b
then do modify $ \st -> st { stFirstPara = False }
return "First_20_paragraph"
else return "Text_20_body"
sty' <- dirStyleFor sty
return $ inTags False "text:p" [("text:style-name", sty')] d
inParagraphTagsWithStyle :: Text -> Doc Text -> Doc Text
inParagraphTagsWithStyle sty = inTags False "text:p" [("text:style-name", sty)]
inSpanTags :: Text -> Doc Text -> Doc Text
inSpanTags s = inTags False "text:span" [("text:style-name",s)]
withAlteredTextStyles :: PandocMonad m
=> (Set.Set TextStyle -> Set.Set TextStyle) -> OD m a -> OD m a
withAlteredTextStyles f action = do
oldTextStyleAttr <- gets stTextStyleAttr
modify $ \st -> st{ stTextStyleAttr = f oldTextStyleAttr }
res <- action
modify $ \st -> st{ stTextStyleAttr = oldTextStyleAttr }
return res
withTextStyle :: PandocMonad m => TextStyle -> OD m a -> OD m a
withTextStyle s = withAlteredTextStyles (Set.insert s)
withDirection :: PandocMonad m => Maybe Direction -> OD m a -> OD m a
withDirection mbdir action = do
olddir <- gets stDirection
modify $ \st -> st{ stDirection = mbdir }
res <- action
modify $ \st -> st{ stDirection = olddir }
return res
-- | Apply the writing direction from a @dir@ attribute, if present.
withDirFromAttr :: PandocMonad m => Attr -> OD m a -> OD m a
withDirFromAttr (_,_,kvs) action =
case lookup "dir" kvs of
Just "rtl" -> withDirection (Just RTL) action
Just "ltr" -> withDirection (Just LTR) action
_ -> action
inTextStyle :: PandocMonad m => Doc Text -> OD m (Doc Text)
inTextStyle d = do
at <- gets stTextStyleAttr
if Set.null at
then return d
else case wellKnownTextStyle at of
Just styleName -> return $
inTags False "text:span" [("text:style-name", styleName)] d
Nothing -> do
styles <- gets stTextStyles
case Map.lookup at styles of
Just (styleName, _) -> return $
inTags False "text:span" [("text:style-name",styleName)] d
Nothing -> do
let styleName = "T" <> tshow (Map.size styles + 1)
addTextStyle at (styleName,
inTags False "style:style"
[("style:name", styleName)
,("style:family", "text")]
$ selfClosingTag "style:text-properties"
(sortOn fst . Map.toList
$ L.foldl' textStyleAttr mempty (Set.toList at)))
return $ inTags False
"text:span" [("text:style-name",styleName)] d
formulaStyles :: [Doc Text]
formulaStyles = [formulaStyle InlineMath, formulaStyle DisplayMath]
formulaStyle :: MathType -> Doc Text
formulaStyle mt = inTags False "style:style"
[("style:name", if mt == InlineMath then "fr1" else "fr2")
,("style:family", "graphic")
,("style:parent-style-name", "Formula")]
$ selfClosingTag "style:graphic-properties" $ if mt == InlineMath then
[("style:vertical-pos", "middle")
,("style:vertical-rel", "text")]
else
[("style:vertical-pos", "middle")
,("style:vertical-rel", "text")
,("style:horizontal-pos", "center")
,("style:horizontal-rel", "paragraph-content")
,("style:wrap", "none")]
inBookmarkTags :: Text -> Doc Text -> Doc Text
inBookmarkTags ident d =
selfClosingTag "text:bookmark-start" [ ("text:name", ident) ]
<> d <>
selfClosingTag "text:bookmark-end" [ ("text:name", ident) ]
selfClosingBookmark :: Text -> Doc Text
selfClosingBookmark ident =
selfClosingTag "text:bookmark" [("text:name", ident)]
inHeaderTags :: PandocMonad m => Int -> Text -> Doc Text -> OD m (Doc Text)
inHeaderTags i ident d = do
sty <- dirStyleFor ("Heading_20_" <> tshow i)
return $ inTags False "text:h" [ ("text:style-name", sty)
, ("text:outline-level", tshow i)]
$ if T.null ident
then d
else inBookmarkTags ident d
inQuotes :: QuoteType -> Doc Text -> Doc Text
inQuotes SingleQuote s = char '\8216' <> s <> char '\8217'
inQuotes DoubleQuote s = char '\8220' <> s <> char '\8221'
handleSpaces :: Text -> Doc Text
handleSpaces s = case T.uncons s of
Just (' ', _) -> genTag s
Just ('\t',x) -> selfClosingTag "text:tab" [] <> rm x
_ -> rm s
where
genTag = T.span (==' ') >>> tag . T.length *** rm >>> uncurry (<>)
tag n = when (n /= 0) $ selfClosingTag "text:s" [("text:c", tshow n)]
rm t = case T.uncons t of
Just ( ' ',xs) -> char ' ' <> genTag xs
Just ('\t',xs) -> selfClosingTag "text:tab" [] <> genTag xs
Just ( x,xs) -> char x <> rm xs
Nothing -> empty
-- | Convert Pandoc document to string in OpenDocument format.
writeOpenDocument :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeOpenDocument opts (Pandoc meta blocks) = do
setupTranslations meta
let colwidth = if writerWrapText opts == WrapAuto
then Just $ writerColumns opts
else Nothing
let meta' = case lookupMetaBlocks "abstract" meta of
[] -> meta
xs -> B.setMeta "abstract"
(B.divWith ("",[],[("custom-style","Abstract")])
(B.fromList xs))
meta
-- Set the default writing direction from the "dir" metadata field;
-- in its absence, a right-to-left main language implies RTL.
let mbDir = case lookupMetaString "dir" meta of
"rtl" -> Just RTL
"ltr" -> Nothing
_ -> case getLang opts meta of
Just l | Right lang <- parseLang l
, isRTLLang lang -> Just RTL
_ -> Nothing
((body, metadata),s) <- flip runStateT
defaultWriterState{ stDirection = mbDir } $ do
let collectBlockIdent (Header _ (ident,_,_) _) = [(ident,HeaderRef)]
collectBlockIdent (Figure (ident,_,_) _ _ ) = [(ident,FigureRef)]
collectBlockIdent (Table (ident,_,_) _ _ _ _ _) = [(ident,TableRef)]
collectBlockIdent _ = []
modify $ \s -> s{ stIdentTypes = query collectBlockIdent blocks }
m <- metaToContext opts
(inlinesToOpenDocument opts . blocksToInlines)
(fmap chomp . inlinesToOpenDocument opts)
meta'
b <- blocksToOpenDocument opts blocks
return (b, m)
let styles = stTableStyles s ++ stParaStyles s ++ formulaStyles ++
map snd (sortBy (comparing (Down . fst)) (
Map.elems (stTextStyles s)))
let listStyles = map snd (Map.elems (stListOverrides s))
let automaticStyles = vcat $ reverse styles ++ listStyles
let context = defField "body" body
. defField "toc" (writerTableOfContents opts)
. defField "toc-depth" (tshow $ writerTOCDepth opts)
. defField "automatic-styles" automaticStyles
$ metadata
return $ render colwidth $
case writerTemplate opts of
Nothing -> body
Just tpl -> renderTemplate tpl context
withParagraphStyle :: PandocMonad m
=> WriterOptions -> Text -> [Block] -> OD m (Doc Text)
withParagraphStyle o s bs = do
s' <- dirStyleFor s
let go (b:bs')
| Para l <- b = cont bs' =<<
inParagraphTagsWithStyle s' <$> inlinesToOpenDocument o l
| otherwise = cont bs' =<< blockToOpenDocument o b
go [] = return empty
cont bs' i = (<>) i <$> go bs'
go bs
inPreformattedTags :: [Doc Text] -> Doc Text
inPreformattedTags s =
inParagraphTagsWithStyle "Preformatted_20_Text" $ hcat s
-- | Get the list-style name to use for an ordered list with the given
-- numbering style and delimiter, registering an override automatic style
-- if needed. Lists with default style/delimiter use the predefined
-- @Numbering_20_1@ style and no override is generated.
orderedListStyleName :: PandocMonad m
=> ListNumberStyle -> ListNumberDelim -> OD m Text
orderedListStyleName ns nd
| (ns == DefaultStyle || ns == Decimal) &&
(nd == DefaultDelim || nd == Period) =
return defaultNumberedListStyleName
| otherwise = do
overrides <- gets stListOverrides
case Map.lookup (ns, nd) overrides of
Just (name, _) -> return name
Nothing -> do
let name = "Pandoc_5f_Numbering_5f_" <>
tshow (Map.size overrides + 1)
doc = inTags True "text:list-style"
[("style:name", name)]
(vcat (map (orderedListLevel ns nd) [1..10]))
modify $ \s -> s { stListOverrides =
Map.insert (ns, nd) (name, doc)
(stListOverrides s) }
return name
orderedListLevel :: ListNumberStyle -> ListNumberDelim -> Int -> Doc Text
orderedListLevel ns nd lvl =
let suffix = case nd of
OneParen -> [("style:num-suffix", ")")]
TwoParens -> [("style:num-prefix", "(")
,("style:num-suffix", ")")]
_ -> [("style:num-suffix", ".")]
format = case ns of
UpperAlpha -> "A"
LowerAlpha -> "a"
UpperRoman -> "I"
LowerRoman -> "i"
_ -> "1"
in inTags True "text:list-level-style-number"
([ ("text:level" , tshow lvl)
, ("text:style-name" , "Numbering_20_Symbols")
, ("style:num-format", format)
] ++ suffix)
(selfClosingTag "style:list-level-properties"
[ ("text:space-before",
T.pack (printf "%.4fin" (0.1972 * fromIntegral (lvl - 1) :: Double)))
, ("text:min-label-width", "0.1965in")
, ("text:min-label-distance", "0.1in")
])
orderedListToOpenDocument :: PandocMonad m
=> WriterOptions -> Text -> [[Block]]
-> OD m (Doc Text)
orderedListToOpenDocument o paraName bs =
vcat . map (inTagsIndented "text:list-item") <$>
mapM (orderedItemToOpenDocument o paraName . map plainToPara) bs
orderedItemToOpenDocument :: PandocMonad m
=> WriterOptions -> Text -> [Block]
-> OD m (Doc Text)
orderedItemToOpenDocument o paraName bs = vcat <$> mapM go bs
where go (OrderedList a l) = orderedList a l
go (Para l) = do
sty <- dirStyleFor paraName
inParagraphTagsWithStyle sty <$> inlinesToOpenDocument o l
go b = blockToOpenDocument o b
orderedList a@(_,ns,nd) l = do
lstName <- orderedListStyleName ns nd
let pn = if isTightList l then numberItemTightStyleName
else numberItemStyleName
let listAttrs = ("text:style-name", lstName) : startValueAttr a
inTags True "text:list" listAttrs <$>
orderedListToOpenDocument o pn l
-- | Generate a @text:start-value@ attribute when the start value is not 1.
startValueAttr :: ListAttributes -> [(Text, Text)]
startValueAttr (s,_,_) | s /= 1 = [("text:start-value", tshow s)]
startValueAttr _ = []
isTightList :: [[Block]] -> Bool
isTightList [] = False
isTightList (b:_)
| Plain {} : _ <- b = True
| otherwise = False
bulletListToOpenDocument :: PandocMonad m
=> WriterOptions -> [[Block]] -> OD m (Doc Text)
bulletListToOpenDocument o b = do
let pn = if isTightList b then bulletItemTightStyleName
else bulletItemStyleName
is <- listItemsToOpenDocument pn o b
return $ inTags True "text:list"
[("text:style-name", defaultBulletListStyleName)] is
listItemsToOpenDocument :: PandocMonad m
=> Text -> WriterOptions -> [[Block]] -> OD m (Doc Text)
listItemsToOpenDocument s o is =
vcat . map (inTagsIndented "text:list-item") <$> mapM (withParagraphStyle o s . map plainToPara) is
deflistItemToOpenDocument :: PandocMonad m
=> WriterOptions -> ([Inline],[[Block]]) -> OD m (Doc Text)
deflistItemToOpenDocument o (t,d) = do
let ts = if isTightList d
then "Definition_20_Term_20_Tight" else "Definition_20_Term"
ds = if isTightList d
then "Definition_20_Definition_20_Tight" else "Definition_20_Definition"
t' <- withParagraphStyle o ts [Para t]
d' <- liftM vcat $ mapM (withParagraphStyle o ds . map plainToPara) d
return $ t' $$ d'
inBlockQuote :: PandocMonad m
=> WriterOptions -> Text -> [Block] -> OD m (Doc Text)
inBlockQuote o sty (b:bs)
| BlockQuote l <- b = do increaseIndent
ni <- paraStyle
[("style:parent-style-name","Quotations")]
inner <- inBlockQuote o ni (map plainToPara l)
resetIndent
go inner
| Para l <- b = go =<< inParagraphTagsWithStyle sty <$> inlinesToOpenDocument o l
| otherwise = go =<< blockToOpenDocument o b
where go block = ($$) block <$> inBlockQuote o sty bs
inBlockQuote _ _ [] = return empty
-- | Convert a list of Pandoc blocks to OpenDocument.
blocksToOpenDocument :: PandocMonad m => WriterOptions -> [Block] -> OD m (Doc Text)
blocksToOpenDocument o b = vcat <$> mapM (blockToOpenDocument o) b
-- | Convert a Pandoc block element to OpenDocument.
blockToOpenDocument :: PandocMonad m => WriterOptions -> Block -> OD m (Doc Text)
blockToOpenDocument o = \case
Plain b -> if null b
then return empty
else inParagraphTags =<< inlinesToOpenDocument o b
Para b -> if null b &&
not (isEnabled Ext_empty_paragraphs o)
then return empty
else inParagraphTags =<< inlinesToOpenDocument o b
LineBlock b -> blockToOpenDocument o $ linesToPara b
Div attr xs -> mkDiv attr xs
Header i (ident,_,_) b -> do
setFirstPara
inHeaderTags i ident =<< inlinesToOpenDocument o b
BlockQuote b -> setFirstPara >> mkBlockQuote b
DefinitionList b -> setFirstPara >> defList b
BulletList b -> setFirstPara >> bulletListToOpenDocument o b
OrderedList a b -> setFirstPara >> orderedList a b
CodeBlock attrs s -> do
setFirstPara
let highlighted =
case highlight (writerSyntaxMap o) formatOpenDocument attrs s of
Right h -> return $ flush . vcat $ map (inTags True "text:p"
[("text:style-name",
"Preformatted_20_Text")] . hcat) h
Left msg -> do
unless (T.null msg) $ report $ CouldNotHighlight msg
unhighlighted s
case writerHighlightMethod o of
Skylighting {} -> highlighted
DefaultHighlighting -> highlighted
_ -> unhighlighted s
Table a bc s th tb tf -> setFirstPara >>
table o (Ann.toTable a bc s th tb tf)
HorizontalRule -> setFirstPara >> return (selfClosingTag "text:p"
[ ("text:style-name", "Horizontal_20_Line") ])
b@(RawBlock f s) -> if f == Format "opendocument"
then return $ text $ T.unpack s
else empty <$ report (BlockNotRendered b)
Figure a capt b -> figure o a capt b
where
defList b = do setInDefinitionList True
r <- vcat <$> mapM (deflistItemToOpenDocument o) b
setInDefinitionList False
return r
unhighlighted s = pure $ flush . vcat $
(map ((inPreformattedTags . (:[])) . preformatted) (T.lines s))
mkDiv attr s = do
let (ident,_,kvs) = attr
i = withDirFromAttr attr $ withLangFromAttr attr $
case lookup "custom-style" kvs of
Just sty -> withParagraphStyle o sty s
_ -> blocksToOpenDocument o s
mkBookmarkedDiv = inTags False "text:section" [("text:name", ident)]
if T.null ident
then i
else fmap mkBookmarkedDiv i
mkBlockQuote b = do sty <- paraStyle
[("style:parent-style-name","Quotations")]
inBlockQuote o sty (map plainToPara b)
orderedList a@(_,ns,nd) b = do
lstName <- orderedListStyleName ns nd
let pn = if isTightList b then numberItemTightStyleName
else numberItemStyleName
let listAttrs = ("text:style-name", lstName) : startValueAttr a
inTags True "text:list" listAttrs <$>
orderedListToOpenDocument o pn b
table :: PandocMonad m => WriterOptions -> Ann.Table -> OD m (Doc Text)
table opts
(Ann.Table (ident, _, _) (Caption _ c) colspecs thead tbodies tfoot) = do
tn <- length <$> gets stTableStyles
pn <- length <$> gets stParaStyles
let genIds = map chr [65..]
name = "Table" <> tshow (tn + 1)
(aligns, mwidths) = unzip colspecs
fromWidth (ColWidth w) | w > 0 = w
fromWidth _ = 0
widths = map fromWidth mwidths
textWidth = sum widths
columnIds = zip genIds widths
mkColumn n = selfClosingTag "table:table-column" [("table:style-name", name <> "." <> T.singleton (fst n))]
columns = map mkColumn columnIds
paraHStyles = paraTableStyles "Heading" pn aligns
paraStyles = paraTableStyles "Contents" (pn + length (newPara paraHStyles)) aligns
newPara = map snd . filter (not . isEmpty . snd)
addTableStyle $ tableStyle tn textWidth columnIds
mapM_ addParaStyle . newPara $ paraHStyles ++ paraStyles
captionDoc <- if null c
then return empty
else inlinesToOpenDocument o (blocksToInlines c) >>=
if isEnabled Ext_native_numbering o
then numberedTableCaption ident
else unNumberedCaption "TableCaption"
th <- colHeadsToOpenDocument o (map fst paraHStyles) thead
tr <- mapM (tableBodyToOpenDocument o (map fst paraHStyles) (map fst paraStyles)) tbodies
tf <- tableFootToOpenDocument o (map fst paraStyles) tfoot
let tableDoc = inTags True "table:table" [
("table:name" , name)
, ("table:style-name", name)
] (vcat columns $$ th $$ vcat tr $$ tf)
return $
case writerTableCaptionPosition opts of
CaptionAbove -> captionDoc $$ tableDoc
CaptionBelow -> tableDoc $$ captionDoc
figure opts (ident, _, _) (Caption _ longcapt) body =
case blocksToInlines longcapt of
[] ->
withParagraphStyle o "Figure" body
caption -> do
imageDoc <- withParagraphStyle o "FigureWithCaption" $
map (\case {Plain i -> Para i; b -> b}) body
captionDoc <- inlinesToOpenDocument o caption >>=
if isEnabled Ext_native_numbering o
then numberedFigureCaption ident
else unNumberedCaption "FigureCaption"
return $
case writerFigureCaptionPosition opts of
CaptionAbove -> captionDoc $$ imageDoc
CaptionBelow -> imageDoc $$ captionDoc
numberedTableCaption :: PandocMonad m => Text -> Doc Text -> OD m (Doc Text)
numberedTableCaption ident caption = do
id' <- gets stTableCaptionId
modify (\st -> st{ stTableCaptionId = id' + 1 })
capterm <- translateTerm Term.Table
sty <- dirStyleFor "TableCaption"
return $ numberedCaption sty capterm "Table" id' ident caption
numberedFigureCaption :: PandocMonad m => Text -> Doc Text -> OD m (Doc Text)
numberedFigureCaption ident caption = do
id' <- gets stImageCaptionId
modify (\st -> st{ stImageCaptionId = id' + 1 })
capterm <- translateTerm Term.Figure
sty <- dirStyleFor "FigureCaption"
return $ numberedCaption sty capterm "Illustration" id' ident caption
numberedCaption :: Text -> Text -> Text -> Int -> Text -> Doc Text -> Doc Text
numberedCaption style term name num ident caption =
let t = text $ T.unpack term
r = num - 1
ident' = case ident of
"" -> "ref" <> name <> tshow r
_ -> ident
s = inTags False "text:sequence" [ ("text:ref-name", ident'),
("text:name", name),
("text:formula", "ooow:" <> name <> "+1"),
("style:num-format", "1") ] $ text $ show num
c = text ": "
in inParagraphTagsWithStyle style $ hcat [ t, text " ", s, c, caption ]
unNumberedCaption :: PandocMonad m => Text -> Doc Text -> OD m (Doc Text)
unNumberedCaption style caption = do
sty <- dirStyleFor style
return $ inParagraphTagsWithStyle sty caption
colHeadsToOpenDocument :: PandocMonad m
=> WriterOptions -> [Text] -> Ann.TableHead
-> OD m (Doc Text)
colHeadsToOpenDocument o ns (Ann.TableHead _ hs) =
case hs of
[] -> return empty
xs -> inTagsIndented "table:table-header-rows" <$>
tableHeaderRowsToOpenDocument o ns "TableHeaderRowCell" xs
tableHeaderRowsToOpenDocument :: PandocMonad m
=> WriterOptions -> [Text] -> Text -> [Ann.HeaderRow]
-> OD m (Doc Text)
tableHeaderRowsToOpenDocument o ns s headerRows =
vcat <$> mapM headerRowToOpenDocument headerRows
where
headerRowToOpenDocument (Ann.HeaderRow _ _ c) =
inTagsIndented "table:table-row" .
vcat <$> mapM (tableItemToOpenDocument o s) (zip ns c)
tableBodyToOpenDocument:: PandocMonad m
=> WriterOptions -> [Text] -> [Text] -> Ann.TableBody
-> OD m (Doc Text)
tableBodyToOpenDocument o headns bodyns tb = do
let (Ann.TableBody _ _ hs r) = tb
tableRowHeaders <- tableHeaderRowsToOpenDocument o headns "TableRowCell" hs
tableRows <- mapM (tableRowToOpenDocument o headns bodyns) r
return $ tableRowHeaders $$ vcat tableRows
tableFootToOpenDocument :: PandocMonad m
=> WriterOptions -> [Text] -> Ann.TableFoot
-> OD m (Doc Text)
tableFootToOpenDocument o ns (Ann.TableFoot _ r) =
tableHeaderRowsToOpenDocument o ns "TableRowCell" r
tableRowToOpenDocument :: PandocMonad m
=> WriterOptions -> [Text] -> [Text] -> Ann.BodyRow
-> OD m (Doc Text)
tableRowToOpenDocument o headns bodyns r =
let (Ann.BodyRow _ _ rowheaders cs) = r
in inTagsIndented "table:table-row" . vcat <$>
mapM (tableItemToOpenDocument o "TableRowCell")
((zip headns rowheaders) ++ (zip (drop (length rowheaders) bodyns) cs))
colspanAttrib :: ColSpan -> [(Text, Text)]
colspanAttrib cs =
case cs of
ColSpan 1 -> mempty
ColSpan n -> [("table:number-columns-spanned", tshow n)]
rowspanAttrib :: RowSpan -> [(Text, Text)]
rowspanAttrib rs =
case rs of
RowSpan 1 -> mempty
RowSpan n -> [("table:number-rows-spanned", tshow n)]
alignAttrib :: Alignment -> [(Text,Text)]
alignAttrib a = case a of
AlignRight -> ("fo:text-align","end") : style
AlignCenter -> ("fo:text-align","center") : style
_ -> []
where
style = [("style:justify-single-word","false")]
tableItemToOpenDocument :: PandocMonad m
=> WriterOptions -> Text -> (Text,Ann.Cell)
-> OD m (Doc Text)
tableItemToOpenDocument o s (n,c) = do
let (Ann.Cell _colspecs _colnum (Cell _ align rs cs i) ) = c
csa = colspanAttrib cs
rsa = rowspanAttrib rs
aa = alignAttrib align
a = [ ("table:style-name" , s )
, ("office:value-type", "string" ) ] ++ csa ++ rsa
itemParaStyle <- paraStyleFromParent n aa
inTags True "table:table-cell" a <$>
withParagraphStyle o itemParaStyle (map plainToPara i)
-- | Convert a list of inline elements to OpenDocument.
inlinesToOpenDocument :: PandocMonad m => WriterOptions -> [Inline] -> OD m (Doc Text)
inlinesToOpenDocument o l = hcat <$> toChunks o l
toChunks :: PandocMonad m => WriterOptions -> [Inline] -> OD m [Doc Text]
toChunks _ [] = return []
toChunks o (x : xs)
| isChunkable x = do
contents <- (inTextStyle . hcat) =<<
mapM (inlineToOpenDocument o) (x:ys)
rest <- toChunks o zs
return (contents : rest)
| otherwise = do
contents <- inlineToOpenDocument o x
rest <- toChunks o xs
return (contents : rest)
where (ys, zs) = span isChunkable xs
isChunkable :: Inline -> Bool
isChunkable (Str _) = True
isChunkable Space = True
isChunkable SoftBreak = True
isChunkable _ = False
-- | Convert an inline element to OpenDocument.
inlineToOpenDocument :: PandocMonad m => WriterOptions -> Inline -> OD m (Doc Text)
inlineToOpenDocument o ils
= case ils of
Space -> return space
SoftBreak
| writerWrapText o == WrapPreserve
-> return $ preformatted "\n"
| otherwise -> return space
Span ("", ["mark"], []) xs ->
inTags False "text:span" [("text:style-name","Highlighted")] <$>
inlinesToOpenDocument o xs
Span attr xs -> mkSpan attr xs
LineBreak -> return $ selfClosingTag "text:line-break" []
Str s -> return $ handleSpaces $ escapeStringForXML s
Emph l -> withTextStyle Italic $ inlinesToOpenDocument o l
Underline l -> withTextStyle Under $ inlinesToOpenDocument o l
Strong l -> withTextStyle Bold $ inlinesToOpenDocument o l
Strikeout l -> withTextStyle Strike $ inlinesToOpenDocument o l
Superscript l -> withTextStyle Sup $ inlinesToOpenDocument o l
Subscript l -> withTextStyle Sub $ inlinesToOpenDocument o l
SmallCaps l -> withTextStyle SmallC $ inlinesToOpenDocument o l
Quoted t l -> inQuotes t <$> inlinesToOpenDocument o l
Code attrs s ->
let highlighted =
case highlight (writerSyntaxMap o) formatOpenDocument attrs s of
Right h -> inlinedCode $ mconcat $ mconcat h
Left msg -> do
unless (T.null msg) $ report $ CouldNotHighlight msg
unhighlighted s
in case writerHighlightMethod o of
Skylighting {} -> highlighted
DefaultHighlighting -> highlighted
_ -> unhighlighted s
Math t s -> lift (texMathToInlines t s) >>=
inlinesToOpenDocument o
Cite _ l -> inlinesToOpenDocument o l
RawInline f s -> if f == Format "opendocument"
then return $ text $ T.unpack s
else do
report $ InlineNotRendered ils
return empty
Link _ l (s,t) -> do
identTypes <- gets stIdentTypes
mkLink o identTypes s t <$> inlinesToOpenDocument o l
Image attr _ (s,t) -> mkImg attr s t
Note l -> mkNote l
where
unhighlighted s = inlinedCode $ preformatted s
inlinedCode s = return $ inTags False "text:span"
[("text:style-name", "Source_20_Text")] s
mkImg (_, _, kvs) s _ = do
id' <- gets stImageId
modify (\st -> st{ stImageId = id' + 1 })
let getDims [] = []
getDims (("width", w) :xs) = ("svg:width", w) : getDims xs
getDims (("rel-width", w):xs) = ("style:rel-width", w) : getDims xs
getDims (("height", h):xs) = ("svg:height", h) : getDims xs
getDims (("rel-height", w):xs) = ("style:rel-height", w) : getDims xs
getDims (_:xs) = getDims xs
-- Image is an Inline: anchor the frame as a character so
-- it flows with the text. Without an explicit anchor,
-- consumers default to paragraph anchoring and float the
-- frame beside the following text.
return $ inTags False "draw:frame"
(("draw:name", "img" <> tshow id')
: ("text:anchor-type", "as-char")
: getDims kvs) $
selfClosingTag "draw:image" [ ("xlink:href" , s )
, ("xlink:type" , "simple")
, ("xlink:show" , "embed" )
, ("xlink:actuate", "onLoad")]
mkSpan attr xs = do
let (ident,_,kvs) = attr
i = maybe id (\sty ->
fmap (inTags False "text:span"
[ ("text:style-name", sty) ]))
(lookup "custom-style" kvs) .
withLangFromAttr attr $ inlinesToOpenDocument o xs
mkBookmarkedSpan b =
if isEmpty b
then selfClosingBookmark ident
else inBookmarkTags ident b
if T.null ident
then i
else fmap mkBookmarkedSpan i
mkNote l = do
n <- length <$> gets stNotes
let footNote t = inTags False "text:note"
[ ("text:id" , "ftn" <> tshow n)
, ("text:note-class", "footnote" )] $
inTagsSimple "text:note-citation" (text . show $ n + 1) <>
inTagsSimple "text:note-body" t
nn <- footNote <$> withAlteredTextStyles (const mempty)
(withParagraphStyle o "Footnote" l)
addNote nn
return nn
formatOpenDocument :: FormatOptions -> [SourceLine] -> [[Doc Text]]
formatOpenDocument _fmtOpts = map (map toHlTok)
toHlTok :: Token -> Doc Text
toHlTok (toktype,tok) =
inTags False "text:span" [("text:style-name", T.pack $ show toktype)] $ preformatted tok
preformatted :: Text -> Doc Text
preformatted s = handleSpaces $ escapeStringForXML s
mkLink :: WriterOptions -> [(Text,ReferenceType)] -> Text -> Text -> Doc Text -> Doc Text
mkLink o identTypes s t d =
let maybeIdentAndType = case T.uncons s of
Just ('#', ident) -> find ((ident ==) . fst) identTypes
_ -> Nothing
d' = inSpanTags "Definition" d
ref refType format ident = inTags False refType
[ ("text:reference-format", format ),
("text:ref-name", ident) ]
inlineSpace = selfClosingTag "text:s" []
bookmarkRef = ref "text:bookmark-ref"
bookmarkRefNumber ident = bookmarkRef "number" ident mempty
bookmarkRefName ident = bookmarkRef "text" ident d
bookmarkRefNameNumber ident = bookmarkRefNumber ident <> inlineSpace <> bookmarkRefName ident
bookmarkRef'
| isEnabled Ext_xrefs_number o && isEnabled Ext_xrefs_name o = bookmarkRefNameNumber
| isEnabled Ext_xrefs_name o = bookmarkRefName
| otherwise = bookmarkRefNumber
sequenceRef = ref "text:sequence-ref"
sequenceRefNumber ident = sequenceRef "value" ident mempty
sequenceRefName ident = sequenceRef "caption" ident d
sequenceRefNameNumber ident = sequenceRefNumber ident <> inlineSpace <> sequenceRefName ident
sequenceRef'
| isEnabled Ext_xrefs_number o && isEnabled Ext_xrefs_name o = sequenceRefNameNumber
| isEnabled Ext_xrefs_name o = sequenceRefName
| otherwise = sequenceRefNumber
link = inTags False "text:a" [ ("xlink:type" , "simple")
, ("xlink:href" , s )
, ("office:name", t )
] d'
linkOrReference = case maybeIdentAndType of
Just (ident, HeaderRef) -> bookmarkRef' ident
Just (ident, TableRef) -> sequenceRef' ident
Just (ident, FigureRef) -> sequenceRef' ident
_ -> link
in if isEnabled Ext_xrefs_name o || isEnabled Ext_xrefs_number o
then linkOrReference
else link
tableStyle :: Int -> Double -> [(Char,Double)] -> Doc Text
tableStyle num textWidth wcs =
let tableId = "Table" <> tshow (num + 1)
tableWidthAttr :: [(Text,Text)]
tableWidthAttr
| textWidth <= 1 && textWidth > 0 = [("style:rel-width",
T.pack (show (round (textWidth * 100) :: Int) <> "%"))]
| otherwise = []
table = inTags True "style:style"
[("style:name", tableId)
,("style:family", "table")] $
selfClosingTag "style:table-properties"
(("table:align", "center") : tableWidthAttr)
colStyle (c,0) = selfClosingTag "style:style"
[ ("style:name" , tableId <> "." <> T.singleton c)
, ("style:family", "table-column" )]
colStyle (c,w) = inTags True "style:style"
[ ("style:name" , tableId <> "." <> T.singleton c)
, ("style:family", "table-column" )] $
selfClosingTag "style:table-column-properties"
[("style:rel-column-width", T.pack $ printf "%d*" (floor $ w * 65535 :: Integer))]
headerRowCellStyle = inTags True "style:style"
[ ("style:name" , "TableHeaderRowCell")
, ("style:family", "table-cell" )] $
selfClosingTag "style:table-cell-properties"
[ ("fo:border", "none")]
rowCellStyle = inTags True "style:style"
[ ("style:name" , "TableRowCell")
, ("style:family", "table-cell" )] $
selfClosingTag "style:table-cell-properties"
[ ("fo:border", "none")]
cellStyles = if num == 0
then headerRowCellStyle $$ rowCellStyle
else empty
columnStyles = map colStyle wcs
in cellStyles $$ table $$ vcat columnStyles
-- | Generate (or reuse) a paragraph style with the given attributes.
-- When the only attribute is @style:parent-style-name@ and no
-- indent/tight overrides are active, the parent name is returned
-- directly (no @Pn@ automatic style is created), so that the
-- predefined style passes through unchanged.
paraStyle :: PandocMonad m => [(Text,Text)] -> OD m Text
paraStyle attrs = do
i <- (*) (0.5 :: Double) . fromIntegral <$> gets stIndentPara
b <- gets stInDefinition
t <- gets stTight
dirAttrs <- getDirAttrs
let indentVal = flip (<>) "in" . tshow $ if b then max 0.5 i else i
tight = if t then [ ("fo:margin-top" , "0in" )
, ("fo:margin-bottom" , "0in" )]
else []
indent = if i /= 0 || b
then [ ("fo:margin-left" , indentVal)
, ("fo:margin-right" , "0in" )
, ("fo:text-indent" , "0in" )
, ("style:auto-text-indent" , "false" )]
else []
attributes = indent <> tight <> dirAttrs
case (attributes, attrs) of
([], [("style:parent-style-name", parent)]) -> return parent
_ -> do
pn <- (+) 1 . length <$> gets stParaStyles
let name = "P" <> tshow pn
styleAttr = [ ("style:name" , name)
, ("style:family", "paragraph") ]
paraProps = if null attributes
then mempty
else selfClosingTag
"style:paragraph-properties" attributes
addParaStyle $ inTags True "style:style" (styleAttr <> attrs) paraProps
return name
paraStyleFromParent :: PandocMonad m => Text -> [(Text,Text)] -> OD m Text
paraStyleFromParent parent attrs = do
dirAttrs <- getDirAttrs
let attrs' = attrs <> dirAttrs
if null attrs'
then return parent
else do
pn <- (+) 1 . length <$> gets stParaStyles
let name = "P" <> tshow pn
styleAttr = [ ("style:name" , name)
, ("style:family" , "paragraph")
, ("style:parent-style-name", parent)]
paraProps = selfClosingTag "style:paragraph-properties" attrs'
addParaStyle $ inTags True "style:style" styleAttr paraProps
return name
getDirAttrs :: PandocMonad m => OD m [(Text, Text)]
getDirAttrs = do
wm <- gets stDirection
pure $
case wm of
Nothing -> []
Just RTL -> [("style:writing-mode", "rl-tb"),
("fo:text-align", "right")]
Just LTR -> [("style:writing-mode", "lr-tb"),
("fo:text-align", "left")]
-- | Adjust a named paragraph style for the current writing direction.
-- When a direction is active, an automatic style derived from the
-- given style with the appropriate @style:writing-mode@ is created
-- (and cached). Automatic style names (@P1@, @P2@, ...) pass through
-- unchanged, since automatic styles are always created with the
-- current direction included.
dirStyleFor :: PandocMonad m => Text -> OD m Text
dirStyleFor parent = do
mbDir <- gets stDirection
case mbDir of
Nothing -> return parent
Just d
| isAutoStyleName parent -> return parent
| otherwise -> do
cache <- gets stDirStyles
case Map.lookup (parent, d) cache of
Just name -> return name
Nothing -> do
name <- paraStyleFromParent parent []
modify $ \st -> st{ stDirStyles =
Map.insert (parent, d) name (stDirStyles st) }
return name
where
isAutoStyleName t = case T.uncons t of
Just ('P', ds) -> not (T.null ds) && T.all isDigit ds
_ -> False
paraTableStyles :: Text -> Int -> [Alignment] -> [(Text, Doc Text)]
paraTableStyles _ _ [] = []
paraTableStyles t s (a:xs)
| AlignRight <- a = ( pName s, res s "end" ) : paraTableStyles t (s + 1) xs
| AlignCenter <- a = ( pName s, res s "center") : paraTableStyles t (s + 1) xs
| otherwise = ("Table_20_" <> t, empty ) : paraTableStyles t s xs
where pName sn = "P" <> tshow (sn + 1)
res sn x = inTags True "style:style"
[ ("style:name" , pName sn )
, ("style:family" , "paragraph" )
, ("style:parent-style-name", "Table_20_" <> t)] $
selfClosingTag "style:paragraph-properties"
[ ("fo:text-align", x)
, ("style:justify-single-word", "false")]
data TextStyle = Italic
| Bold
| Under
| Strike
| Sub
| Sup
| SmallC
| Pre
| Language Lang
deriving ( Eq,Ord )
textStyleAttr :: Map.Map Text Text
-> TextStyle
-> Map.Map Text Text
textStyleAttr m = \case
Italic -> Map.insert "fo:font-style" "italic" .
Map.insert "style:font-style-asian" "italic" .
Map.insert "style:font-style-complex" "italic" $ m
Bold -> Map.insert "fo:font-weight" "bold" .
Map.insert "style:font-weight-asian" "bold" .
Map.insert "style:font-weight-complex" "bold" $ m
Under -> Map.insert "style:text-underline-style" "solid" .
Map.insert "style:text-underline-width" "auto" .
Map.insert "style:text-underline-color" "font-color" $ m
Strike -> Map.insert "style:text-line-through-style" "solid" m
Sub -> Map.insert "style:text-position" "sub 58%" m
Sup -> Map.insert "style:text-position" "super 58%" m
SmallC -> Map.insert "fo:font-variant" "small-caps" m
Pre -> Map.insert "style:font-name" "Courier New" .
Map.insert "style:font-name-asian" "Courier New" .
Map.insert "style:font-name-complex" "Courier New" $ m
Language lang -> addLanguage lang m
addLanguage :: Lang -> Map.Map Text Text -> Map.Map Text Text
addLanguage lang
| isRTLLang lang =
Map.insert "style:language-complex" (langLanguage lang) .
maybe id (Map.insert "style:country-complex") (langRegion lang)
| otherwise =
Map.insert "fo:language" (langLanguage lang) .
maybe id (Map.insert "fo:country") (langRegion lang)
-- | Returns True if the language is conventionally written right-to-left.
isRTLLang :: Lang -> Bool
isRTLLang Lang{ langLanguage = l } =
l `elem` ["ar", "he", "fa", "ur", "sd", "ckb", "yi", "dv"]
withLangFromAttr :: PandocMonad m => Attr -> OD m a -> OD m a
withLangFromAttr (_,_,kvs) action =
case lookup "lang" kvs of
Nothing -> action
Just l ->
case parseLang l of
Right lang -> withTextStyle (Language lang) action
Left _ -> do
report $ InvalidLang l
action