pandoc-3.12.1: 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.Monad (unless, liftM, when)
import Control.Monad.State.Strict ( StateT(..), modify, gets, lift )
import Data.Char (chr, isDigit)
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 { stNoteCount :: Int
, stTableStyles :: [Doc Text]
, stTableStyleCount :: Int
, stParaStyles :: [Doc Text]
, stParaStyleCount :: Int
, stParaStyleCache :: Map.Map ([(Text,Text)],[(Text,Text)]) Text
-- ^ cache of automatic paragraph styles, keyed on
-- (style attributes, paragraph properties)
, stListOverrides :: Map.Map (ListNumberStyle,ListNumberDelim)
(Text, Doc Text)
, stTextStyles :: Map.Map (Set.Set TextStyle)
(Int, Doc Text)
-- ^ automatic text styles, with the number that
-- makes up the style's @Tn@ name
, stTextStyleAttr :: Set.Set TextStyle
, stIndentPara :: Int
, stInDefinition :: Bool
, stFirstPara :: Bool
, stImageId :: Int
, stTableCaptionId :: Int
, stImageCaptionId :: Int
, stIdentTypes :: Map.Map Text ReferenceType
, stDirection :: Maybe Direction
-- ^ active writing mode
}
defaultWriterState :: WriterState
defaultWriterState =
WriterState { stNoteCount = 0
, stTableStyles = []
, stTableStyleCount = 0
, stParaStyles = []
, stParaStyleCount = 0
, stParaStyleCache = Map.empty
, stListOverrides = Map.empty
, stTextStyles = Map.empty
, stTextStyleAttr = Set.empty
, stIndentPara = 0
, stInDefinition = False
, stFirstPara = False
, stImageId = 1
, stTableCaptionId = 1
, stImageCaptionId = 1
, stIdentTypes = Map.empty
, stDirection = Nothing
}
addTableStyle :: PandocMonad m => Doc Text -> OD m ()
addTableStyle i = modify $ \s ->
s { stTableStyles = i : stTableStyles s
, stTableStyleCount = stTableStyleCount s + 1 }
addParaStyle :: PandocMonad m => Doc Text -> OD m ()
addParaStyle i = modify $ \s ->
s { stParaStyles = i : stParaStyles s
, stParaStyleCount = stParaStyleCount s + 1 }
addTextStyle :: PandocMonad m
=> Set.Set TextStyle -> (Int, 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 (num, _) -> return $
inTags False "text:span"
[("text:style-name", textStyleName num)] d
Nothing -> do
let num = Map.size styles + 1
styleName = textStyleName num
addTextStyle at (num,
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
-- | Name of the @n@th automatic text style.
textStyleName :: Int -> Text
textStyleName num = "T" <> tshow num
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) -> tabTag <> rm x
_ -> rm s
where
tabTag = selfClosingTag "text:tab" []
-- collapse a run of spaces into a single <text:s>
genTag t = let (spaces, t') = T.span (== ' ') t
in tag (T.length spaces) <> rm t'
tag 0 = empty
tag n = selfClosingTag "text:s" [("text:c", tshow n)]
-- emit text verbatim up to the next space or tab; a lone space is
-- kept literal and any further ones become a <text:s>
rm t = let (chunk, t') = T.break (\c -> c == ' ' || c == '\t') t
pre = if T.null chunk then empty else literal chunk
in case T.uncons t' of
Just (' ', xs) -> pre <> char ' ' <> genTag xs
Just (_ , xs) -> pre <> tabTag <> genTag xs
Nothing -> pre
-- | 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
-- The abstract is the one template field that takes block-level
-- content, so it is rendered separately; everything else in the
-- metadata goes in a context where only inlines are allowed.
let abstractBlocks = case lookupMetaBlocks "abstract" meta of
[] -> []
xs -> [Div ("",[],[("custom-style","Abstract")]) xs]
let meta' = B.deleteMeta "abstract" 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, abstract, metadata),s) <- flip runStateT
defaultWriterState{ stDirection = mbDir } $ do
let collectBlockIdent (Header _ attr _) = identRef HeaderRef attr
collectBlockIdent (Figure attr _ _ ) = identRef FigureRef attr
collectBlockIdent (Table attr _ _ _ _ _) = identRef TableRef attr
collectBlockIdent _ = []
identRef ty (ident,_,_)
| T.null ident = []
| otherwise = [(ident, ty)]
-- only needed to resolve cross references
when (isEnabled Ext_xrefs_name opts ||
isEnabled Ext_xrefs_number opts) $
modify $ \s -> s{ stIdentTypes =
Map.fromListWith (\_ old -> old)
(query collectBlockIdent blocks) }
m <- metaToContext opts
(inlinesToOpenDocument opts . blocksToInlines)
(fmap chomp . inlinesToOpenDocument opts)
meta'
a <- blocksToOpenDocument opts abstractBlocks
b <- blocksToOpenDocument opts blocks
return (b, a, m)
-- 'styles' is reversed below, so the text styles are put in
-- descending order here to come out as T1, T2, ..., T10
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
. (if null abstractBlocks
then id
else defField "abstract" abstract)
$ 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
-- 'Plain' is treated like 'Para' so that the requested style is not
-- lost (e.g. for metadata fields, figure bodies, or tight list items)
let go (b:bs')
| Para l <- b = cont bs' =<< styled l
| Plain l <- b = cont bs' =<< styled l
| otherwise = cont bs' =<< blockToOpenDocument o b
go [] = return empty
cont bs' i = (<>) i <$> go bs'
styled l = inParagraphTagsWithStyle s' <$> inlinesToOpenDocument o l
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 $ literal 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 <- gets stTableStyleCount
pn <- gets stParaStyleCount
let genIds = map colLetters [0..]
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 <> "." <> 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" 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 = literal 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 $ literal 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 <- gets stNoteCount
-- bump the counter before rendering the body, so that a note
-- nested inside this one does not reuse the same text:id
modify $ \st -> st{ stNoteCount = n + 1 }
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
footNote <$> withAlteredTextStyles (const mempty)
(withParagraphStyle o "Footnote" l)
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 -> Map.Map Text ReferenceType -> Text -> Text
-> Doc Text -> Doc Text
mkLink o identTypes s t d =
let 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 T.uncons s of
Just ('#', ident) ->
case Map.lookup ident identTypes of
Just HeaderRef -> bookmarkRef' ident
Just TableRef -> sequenceRef' ident
Just FigureRef -> sequenceRef' ident
Nothing -> link
_ -> link
in if isEnabled Ext_xrefs_name o || isEnabled Ext_xrefs_number o
then linkOrReference
else link
-- | Spreadsheet-style column names (@A@, @B@, ..., @Z@, @AA@, @AB@, ...).
-- Plain @chr@ arithmetic would run past @Z@ into characters like @[@
-- and @\\@, which are not legal in a @style:name@.
colLetters :: Int -> Text
colLetters n
| n < 26 = T.singleton (chr (65 + n))
| otherwise = colLetters (n `div` 26 - 1) <> T.singleton (chr (65 + n `mod` 26))
tableStyle :: Int -> Double -> [(Text,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 <> "." <> c)
, ("style:family", "table-column" )]
colStyle (c,w) = inTags True "style:style"
[ ("style:name" , tableId <> "." <> 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
dirAttrs <- getDirAttrs
let indentVal = flip (<>) "in" . tshow $ if b then max 0.5 i else i
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 <> dirAttrs
case (attributes, attrs) of
([], [("style:parent-style-name", parent)]) -> return parent
_ -> mkParaStyle attrs attributes
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 mkParaStyle [("style:parent-style-name", parent)] attrs'
-- | Create an automatic paragraph style with the given @style:style@
-- attributes and @style:paragraph-properties@, reusing an identical
-- style if one has already been created.
mkParaStyle :: PandocMonad m => [(Text,Text)] -> [(Text,Text)] -> OD m Text
mkParaStyle attrs props = do
cache <- gets stParaStyleCache
case Map.lookup (attrs, props) cache of
Just name -> return name
Nothing -> do
name <- ("P" <>) . tshow . (+ 1) <$> gets stParaStyleCount
let styleAttr = ("style:name" , name)
: ("style:family", "paragraph")
: attrs
paraProps = if null props
then mempty
else selfClosingTag
"style:paragraph-properties" props
addParaStyle $ inTags True "style:style" styleAttr paraProps
modify $ \st -> st{ stParaStyleCache =
Map.insert (attrs, props) name
(stParaStyleCache st) }
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.
-- With no direction active the name passes through unchanged, as do
-- automatic style names (@P1@, @P2@, ...), since automatic styles are
-- always created with the current direction included.
dirStyleFor :: PandocMonad m => Text -> OD m Text
dirStyleFor parent
| isAutoStyleName parent = return parent
| otherwise = paraStyleFromParent parent []
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