1{-# LANGUAGE FlexibleContexts #-} 2{-# LANGUAGE OverloadedStrings #-} 3{-# LANGUAGE PatternGuards #-} 4{-# LANGUAGE ViewPatterns #-} 5{- | 6 Module : Text.Pandoc.Writers.OpenDocument 7 Copyright : Copyright (C) 2008-2020 Andrea Rossato and John MacFarlane 8 License : GNU GPL, version 2 or above 9 10 Maintainer : Andrea Rossato <andrea.rossato@ing.unitn.it> 11 Stability : alpha 12 Portability : portable 13 14Conversion of 'Pandoc' documents to OpenDocument XML. 15-} 16module Text.Pandoc.Writers.OpenDocument ( writeOpenDocument ) where 17import Control.Arrow ((***), (>>>)) 18import Control.Monad.State.Strict hiding (when) 19import Data.Char (chr) 20import Data.Foldable (find) 21import Data.List (sortOn, sortBy, foldl') 22import qualified Data.Map as Map 23import Data.Maybe (fromMaybe, isNothing) 24import Data.Ord (comparing) 25import qualified Data.Set as Set 26import Data.Text (Text) 27import qualified Data.Text as T 28import Text.Pandoc.BCP47 (Lang (..), parseBCP47) 29import Text.Pandoc.Class.PandocMonad (PandocMonad, report, translateTerm, 30 setTranslations, toLang) 31import Text.Pandoc.Definition 32import qualified Text.Pandoc.Builder as B 33import Text.Pandoc.Logging 34import Text.Pandoc.Options 35import Text.DocLayout 36import Text.Pandoc.Shared (linesToPara, tshow, blocksToInlines) 37import Text.Pandoc.Templates (renderTemplate) 38import qualified Text.Pandoc.Translations as Term (Term(Figure, Table)) 39import Text.Pandoc.Walk 40import Text.Pandoc.Writers.Math 41import Text.Pandoc.Writers.Shared 42import qualified Text.Pandoc.Writers.AnnotatedTable as Ann 43import Text.Pandoc.XML 44import Text.Printf (printf) 45import Text.Pandoc.Highlighting (highlight) 46import Skylighting 47 48-- | Auxiliary function to convert Plain block to Para. 49plainToPara :: Block -> Block 50plainToPara (Plain x) = Para x 51plainToPara x = x 52 53-- 54-- OpenDocument writer 55-- 56 57type OD m = StateT WriterState m 58 59data ReferenceType 60 = HeaderRef 61 | TableRef 62 | ImageRef 63 64data WriterState = 65 WriterState { stNotes :: [Doc Text] 66 , stTableStyles :: [Doc Text] 67 , stParaStyles :: [Doc Text] 68 , stListStyles :: [(Int, [Doc Text])] 69 , stTextStyles :: Map.Map (Set.Set TextStyle) 70 (Text, Doc Text) 71 , stTextStyleAttr :: Set.Set TextStyle 72 , stIndentPara :: Int 73 , stInDefinition :: Bool 74 , stTight :: Bool 75 , stFirstPara :: Bool 76 , stImageId :: Int 77 , stTableCaptionId :: Int 78 , stImageCaptionId :: Int 79 , stIdentTypes :: [(Text,ReferenceType)] 80 } 81 82defaultWriterState :: WriterState 83defaultWriterState = 84 WriterState { stNotes = [] 85 , stTableStyles = [] 86 , stParaStyles = [] 87 , stListStyles = [] 88 , stTextStyles = Map.empty 89 , stTextStyleAttr = Set.empty 90 , stIndentPara = 0 91 , stInDefinition = False 92 , stTight = False 93 , stFirstPara = False 94 , stImageId = 1 95 , stTableCaptionId = 1 96 , stImageCaptionId = 1 97 , stIdentTypes = [] 98 } 99 100when :: Bool -> Doc Text -> Doc Text 101when p a = if p then a else empty 102 103addTableStyle :: PandocMonad m => Doc Text -> OD m () 104addTableStyle i = modify $ \s -> s { stTableStyles = i : stTableStyles s } 105 106addNote :: PandocMonad m => Doc Text -> OD m () 107addNote i = modify $ \s -> s { stNotes = i : stNotes s } 108 109addParaStyle :: PandocMonad m => Doc Text -> OD m () 110addParaStyle i = modify $ \s -> s { stParaStyles = i : stParaStyles s } 111 112addTextStyle :: PandocMonad m 113 => Set.Set TextStyle -> (Text, Doc Text) -> OD m () 114addTextStyle attrs i = modify $ \s -> 115 s { stTextStyles = Map.insert attrs i (stTextStyles s) } 116 117addTextStyleAttr :: PandocMonad m => TextStyle -> OD m () 118addTextStyleAttr t = modify $ \s -> 119 s { stTextStyleAttr = Set.insert t (stTextStyleAttr s) } 120 121increaseIndent :: PandocMonad m => OD m () 122increaseIndent = modify $ \s -> s { stIndentPara = 1 + stIndentPara s } 123 124resetIndent :: PandocMonad m => OD m () 125resetIndent = modify $ \s -> s { stIndentPara = stIndentPara s - 1 } 126 127inTightList :: PandocMonad m => OD m a -> OD m a 128inTightList f = modify (\s -> s { stTight = True }) >> f >>= \r -> 129 modify (\s -> s { stTight = False }) >> return r 130 131setInDefinitionList :: PandocMonad m => Bool -> OD m () 132setInDefinitionList b = modify $ \s -> s { stInDefinition = b } 133 134setFirstPara :: PandocMonad m => OD m () 135setFirstPara = modify $ \s -> s { stFirstPara = True } 136 137inParagraphTags :: PandocMonad m => Doc Text -> OD m (Doc Text) 138inParagraphTags d = do 139 b <- gets stFirstPara 140 a <- if b 141 then do modify $ \st -> st { stFirstPara = False } 142 return [("text:style-name", "First_20_paragraph")] 143 else return [("text:style-name", "Text_20_body")] 144 return $ inTags False "text:p" a d 145 146inParagraphTagsWithStyle :: Text -> Doc Text -> Doc Text 147inParagraphTagsWithStyle sty = inTags False "text:p" [("text:style-name", sty)] 148 149inSpanTags :: Text -> Doc Text -> Doc Text 150inSpanTags s = inTags False "text:span" [("text:style-name",s)] 151 152withTextStyle :: PandocMonad m => TextStyle -> OD m a -> OD m a 153withTextStyle s f = do 154 oldTextStyleAttr <- gets stTextStyleAttr 155 addTextStyleAttr s 156 res <- f 157 modify $ \st -> st{ stTextStyleAttr = oldTextStyleAttr } 158 return res 159 160inTextStyle :: PandocMonad m => Doc Text -> OD m (Doc Text) 161inTextStyle d = do 162 at <- gets stTextStyleAttr 163 if Set.null at 164 then return d 165 else do 166 styles <- gets stTextStyles 167 case Map.lookup at styles of 168 Just (styleName, _) -> return $ 169 inTags False "text:span" [("text:style-name",styleName)] d 170 Nothing -> do 171 let styleName = "T" <> tshow (Map.size styles + 1) 172 addTextStyle at (styleName, 173 inTags False "style:style" 174 [("style:name", styleName) 175 ,("style:family", "text")] 176 $ selfClosingTag "style:text-properties" 177 (sortOn fst . Map.toList 178 $ foldl' textStyleAttr mempty (Set.toList at))) 179 return $ inTags False 180 "text:span" [("text:style-name",styleName)] d 181 182formulaStyles :: [Doc Text] 183formulaStyles = [formulaStyle InlineMath, formulaStyle DisplayMath] 184 185formulaStyle :: MathType -> Doc Text 186formulaStyle mt = inTags False "style:style" 187 [("style:name", if mt == InlineMath then "fr1" else "fr2") 188 ,("style:family", "graphic") 189 ,("style:parent-style-name", "Formula")] 190 $ selfClosingTag "style:graphic-properties" $ if mt == InlineMath then 191 [("style:vertical-pos", "middle") 192 ,("style:vertical-rel", "text")] 193 else 194 [("style:vertical-pos", "middle") 195 ,("style:vertical-rel", "paragraph-content") 196 ,("style:horizontal-pos", "center") 197 ,("style:horizontal-rel", "paragraph-content") 198 ,("style:wrap", "none")] 199 200inBookmarkTags :: Text -> Doc Text -> Doc Text 201inBookmarkTags ident d = 202 selfClosingTag "text:bookmark-start" [ ("text:name", ident) ] 203 <> d <> 204 selfClosingTag "text:bookmark-end" [ ("text:name", ident) ] 205 206selfClosingBookmark :: Text -> Doc Text 207selfClosingBookmark ident = 208 selfClosingTag "text:bookmark" [("text:name", ident)] 209 210inHeaderTags :: PandocMonad m => Int -> Text -> Doc Text -> OD m (Doc Text) 211inHeaderTags i ident d = 212 return $ inTags False "text:h" [ ("text:style-name", "Heading_20_" <> tshow i) 213 , ("text:outline-level", tshow i)] 214 $ if T.null ident 215 then d 216 else inBookmarkTags ident d 217 218inQuotes :: QuoteType -> Doc Text -> Doc Text 219inQuotes SingleQuote s = char '\8216' <> s <> char '\8217' 220inQuotes DoubleQuote s = char '\8220' <> s <> char '\8221' 221 222handleSpaces :: Text -> Doc Text 223handleSpaces s = case T.uncons s of 224 Just (' ', _) -> genTag s 225 Just ('\t',x) -> selfClosingTag "text:tab" [] <> rm x 226 _ -> rm s 227 where 228 genTag = T.span (==' ') >>> tag . T.length *** rm >>> uncurry (<>) 229 tag n = when (n /= 0) $ selfClosingTag "text:s" [("text:c", tshow n)] 230 rm t = case T.uncons t of 231 Just ( ' ',xs) -> char ' ' <> genTag xs 232 Just ('\t',xs) -> selfClosingTag "text:tab" [] <> genTag xs 233 Just ( x,xs) -> char x <> rm xs 234 Nothing -> empty 235 236-- | Convert Pandoc document to string in OpenDocument format. 237writeOpenDocument :: PandocMonad m => WriterOptions -> Pandoc -> m Text 238writeOpenDocument opts (Pandoc meta blocks) = do 239 let defLang = Lang "en" "US" "" [] 240 lang <- case lookupMetaString "lang" meta of 241 "" -> pure defLang 242 s -> fromMaybe defLang <$> toLang (Just s) 243 setTranslations lang 244 let colwidth = if writerWrapText opts == WrapAuto 245 then Just $ writerColumns opts 246 else Nothing 247 let meta' = case lookupMetaBlocks "abstract" meta of 248 [] -> meta 249 xs -> B.setMeta "abstract" 250 (B.divWith ("",[],[("custom-style","Abstract")]) 251 (B.fromList xs)) 252 meta 253 ((body, metadata),s) <- flip runStateT 254 defaultWriterState $ do 255 let collectInlineIdent (Image (ident,_,_) _ _) = [(ident,ImageRef)] 256 collectInlineIdent _ = [] 257 let collectBlockIdent (Header _ (ident,_,_) _) = [(ident,HeaderRef)] 258 collectBlockIdent (Table (ident,_,_) _ _ _ _ _) = [(ident,TableRef)] 259 collectBlockIdent _ = [] 260 modify $ \s -> s{ stIdentTypes = query collectBlockIdent blocks ++ query collectInlineIdent blocks } 261 m <- metaToContext opts 262 (blocksToOpenDocument opts) 263 (fmap chomp . inlinesToOpenDocument opts) 264 meta' 265 b <- blocksToOpenDocument opts blocks 266 return (b, m) 267 let styles = stTableStyles s ++ stParaStyles s ++ formulaStyles ++ 268 map snd (sortBy (flip (comparing fst)) ( 269 Map.elems (stTextStyles s))) 270 listStyle (n,l) = inTags True "text:list-style" 271 [("style:name", "L" <> tshow n)] (vcat l) 272 let listStyles = map listStyle (stListStyles s) 273 let automaticStyles = vcat $ reverse $ styles ++ listStyles 274 let context = defField "body" body 275 . defField "toc" (writerTableOfContents opts) 276 . defField "toc-depth" (tshow $ writerTOCDepth opts) 277 . defField "automatic-styles" automaticStyles 278 $ metadata 279 return $ render colwidth $ 280 case writerTemplate opts of 281 Nothing -> body 282 Just tpl -> renderTemplate tpl context 283 284withParagraphStyle :: PandocMonad m 285 => WriterOptions -> Text -> [Block] -> OD m (Doc Text) 286withParagraphStyle o s (b:bs) 287 | Para l <- b = go =<< inParagraphTagsWithStyle s <$> inlinesToOpenDocument o l 288 | otherwise = go =<< blockToOpenDocument o b 289 where go i = (<>) i <$> withParagraphStyle o s bs 290withParagraphStyle _ _ [] = return empty 291 292inPreformattedTags :: PandocMonad m => Text -> OD m (Doc Text) 293inPreformattedTags s = do 294 n <- paraStyle [("style:parent-style-name","Preformatted_20_Text")] 295 return . inParagraphTagsWithStyle ("P" <> tshow n) . handleSpaces $ s 296 297orderedListToOpenDocument :: PandocMonad m 298 => WriterOptions -> Int -> [[Block]] -> OD m (Doc Text) 299orderedListToOpenDocument o pn bs = 300 vcat . map (inTagsIndented "text:list-item") <$> 301 mapM (orderedItemToOpenDocument o pn . map plainToPara) bs 302 303orderedItemToOpenDocument :: PandocMonad m 304 => WriterOptions -> Int -> [Block] -> OD m (Doc Text) 305orderedItemToOpenDocument o n bs = vcat <$> mapM go bs 306 where go (OrderedList a l) = newLevel a l 307 go (Para l) = inParagraphTagsWithStyle ("P" <> tshow n) <$> 308 inlinesToOpenDocument o l 309 go b = blockToOpenDocument o b 310 newLevel a l = do 311 nn <- length <$> gets stParaStyles 312 ls <- head <$> gets stListStyles 313 modify $ \s -> s { stListStyles = orderedListLevelStyle a ls : 314 drop 1 (stListStyles s) } 315 inTagsIndented "text:list" <$> orderedListToOpenDocument o nn l 316 317isTightList :: [[Block]] -> Bool 318isTightList [] = False 319isTightList (b:_) 320 | Plain {} : _ <- b = True 321 | otherwise = False 322 323newOrderedListStyle :: PandocMonad m 324 => Bool -> ListAttributes -> OD m (Int,Int) 325newOrderedListStyle b a = do 326 ln <- (+) 1 . length <$> gets stListStyles 327 let nbs = orderedListLevelStyle a (ln, []) 328 pn <- if b then inTightList (paraListStyle ln) else paraListStyle ln 329 modify $ \s -> s { stListStyles = nbs : stListStyles s } 330 return (ln,pn) 331 332bulletListToOpenDocument :: PandocMonad m 333 => WriterOptions -> [[Block]] -> OD m (Doc Text) 334bulletListToOpenDocument o b = do 335 ln <- (+) 1 . length <$> gets stListStyles 336 (pn,ns) <- if isTightList b then inTightList (bulletListStyle ln) else bulletListStyle ln 337 modify $ \s -> s { stListStyles = ns : stListStyles s } 338 is <- listItemsToOpenDocument ("P" <> tshow pn) o b 339 return $ inTags True "text:list" [("text:style-name", "L" <> tshow ln)] is 340 341listItemsToOpenDocument :: PandocMonad m 342 => Text -> WriterOptions -> [[Block]] -> OD m (Doc Text) 343listItemsToOpenDocument s o is = 344 vcat . map (inTagsIndented "text:list-item") <$> mapM (withParagraphStyle o s . map plainToPara) is 345 346deflistItemToOpenDocument :: PandocMonad m 347 => WriterOptions -> ([Inline],[[Block]]) -> OD m (Doc Text) 348deflistItemToOpenDocument o (t,d) = do 349 let ts = if isTightList d 350 then "Definition_20_Term_20_Tight" else "Definition_20_Term" 351 ds = if isTightList d 352 then "Definition_20_Definition_20_Tight" else "Definition_20_Definition" 353 t' <- withParagraphStyle o ts [Para t] 354 d' <- liftM vcat $ mapM (withParagraphStyle o ds . map plainToPara) d 355 return $ t' $$ d' 356 357inBlockQuote :: PandocMonad m 358 => WriterOptions -> Int -> [Block] -> OD m (Doc Text) 359inBlockQuote o i (b:bs) 360 | BlockQuote l <- b = do increaseIndent 361 ni <- paraStyle 362 [("style:parent-style-name","Quotations")] 363 go =<< inBlockQuote o ni (map plainToPara l) 364 | Para l <- b = go =<< inParagraphTagsWithStyle ("P" <> tshow i) <$> inlinesToOpenDocument o l 365 | otherwise = go =<< blockToOpenDocument o b 366 where go block = ($$) block <$> inBlockQuote o i bs 367inBlockQuote _ _ [] = resetIndent >> return empty 368 369-- | Convert a list of Pandoc blocks to OpenDocument. 370blocksToOpenDocument :: PandocMonad m => WriterOptions -> [Block] -> OD m (Doc Text) 371blocksToOpenDocument o b = vcat <$> mapM (blockToOpenDocument o) b 372 373-- | Convert a Pandoc block element to OpenDocument. 374blockToOpenDocument :: PandocMonad m => WriterOptions -> Block -> OD m (Doc Text) 375blockToOpenDocument o bs 376 | Plain b <- bs = if null b 377 then return empty 378 else inParagraphTags =<< inlinesToOpenDocument o b 379 | Para [Image attr c (s,T.stripPrefix "fig:" -> Just t)] <- bs 380 = figure attr c s t 381 | Para b <- bs = if null b && 382 not (isEnabled Ext_empty_paragraphs o) 383 then return empty 384 else inParagraphTags =<< inlinesToOpenDocument o b 385 | LineBlock b <- bs = blockToOpenDocument o $ linesToPara b 386 | Div attr xs <- bs = mkDiv attr xs 387 | Header i (ident,_,_) b 388 <- bs = setFirstPara >> (inHeaderTags i ident 389 =<< inlinesToOpenDocument o b) 390 | BlockQuote b <- bs = setFirstPara >> mkBlockQuote b 391 | DefinitionList b <- bs = setFirstPara >> defList b 392 | BulletList b <- bs = setFirstPara >> bulletListToOpenDocument o b 393 | OrderedList a b <- bs = setFirstPara >> orderedList a b 394 | CodeBlock _ s <- bs = setFirstPara >> preformatted s 395 | Table a bc s th tb tf <- bs = setFirstPara >> table (Ann.toTable a bc s th tb tf) 396 | HorizontalRule <- bs = setFirstPara >> return (selfClosingTag "text:p" 397 [ ("text:style-name", "Horizontal_20_Line") ]) 398 | RawBlock f s <- bs = if f == Format "opendocument" 399 then return $ text $ T.unpack s 400 else do 401 report $ BlockNotRendered bs 402 return empty 403 | Null <- bs = return empty 404 | otherwise = return empty 405 where 406 defList b = do setInDefinitionList True 407 r <- vcat <$> mapM (deflistItemToOpenDocument o) b 408 setInDefinitionList False 409 return r 410 preformatted s = flush . vcat <$> mapM (inPreformattedTags . escapeStringForXML) (T.lines s) 411 mkDiv attr s = do 412 let (ident,_,kvs) = attr 413 i = withLangFromAttr attr $ 414 case lookup "custom-style" kvs of 415 Just sty -> withParagraphStyle o sty s 416 _ -> blocksToOpenDocument o s 417 mkBookmarkedDiv = inTags False "text:section" [("text:name", ident)] 418 if T.null ident 419 then i 420 else fmap mkBookmarkedDiv i 421 mkBlockQuote b = do increaseIndent 422 i <- paraStyle 423 [("style:parent-style-name","Quotations")] 424 inBlockQuote o i (map plainToPara b) 425 orderedList a b = do (ln,pn) <- newOrderedListStyle (isTightList b) a 426 inTags True "text:list" [ ("text:style-name", "L" <> tshow ln)] 427 <$> orderedListToOpenDocument o pn b 428 table :: PandocMonad m => Ann.Table -> OD m (Doc Text) 429 table (Ann.Table (ident, _, _) (Caption _ c) colspecs thead tbodies _) = do 430 tn <- length <$> gets stTableStyles 431 pn <- length <$> gets stParaStyles 432 let genIds = map chr [65..] 433 name = "Table" <> tshow (tn + 1) 434 (aligns, mwidths) = unzip colspecs 435 fromWidth (ColWidth w) | w > 0 = w 436 fromWidth _ = 0 437 widths = map fromWidth mwidths 438 textWidth = sum widths 439 columnIds = zip genIds widths 440 mkColumn n = selfClosingTag "table:table-column" [("table:style-name", name <> "." <> T.singleton (fst n))] 441 columns = map mkColumn columnIds 442 paraHStyles = paraTableStyles "Heading" pn aligns 443 paraStyles = paraTableStyles "Contents" (pn + length (newPara paraHStyles)) aligns 444 newPara = map snd . filter (not . isEmpty . snd) 445 addTableStyle $ tableStyle tn textWidth columnIds 446 mapM_ addParaStyle . newPara $ paraHStyles ++ paraStyles 447 captionDoc <- if null c 448 then return empty 449 else inlinesToOpenDocument o (blocksToInlines c) >>= 450 if isEnabled Ext_native_numbering o 451 then numberedTableCaption ident 452 else unNumberedCaption "TableCaption" 453 th <- colHeadsToOpenDocument o (map fst paraHStyles) thead 454 tr <- mapM (tableBodyToOpenDocument o (map fst paraStyles)) tbodies 455 let tableDoc = inTags True "table:table" [ 456 ("table:name" , name) 457 , ("table:style-name", name) 458 ] (vcat columns $$ th $$ vcat tr) 459 return $ captionDoc $$ tableDoc 460 figure attr@(ident, _, _) caption source title | null caption = 461 withParagraphStyle o "Figure" [Para [Image attr caption (source,title)]] 462 | otherwise = do 463 imageDoc <- withParagraphStyle o "FigureWithCaption" [Para [Image attr caption (source,title)]] 464 captionDoc <- inlinesToOpenDocument o caption >>= 465 if isEnabled Ext_native_numbering o 466 then numberedFigureCaption ident 467 else unNumberedCaption "FigureCaption" 468 return $ imageDoc $$ captionDoc 469 470 471numberedTableCaption :: PandocMonad m => Text -> Doc Text -> OD m (Doc Text) 472numberedTableCaption ident caption = do 473 id' <- gets stTableCaptionId 474 modify (\st -> st{ stTableCaptionId = id' + 1 }) 475 capterm <- translateTerm Term.Table 476 return $ numberedCaption "TableCaption" capterm "Table" id' ident caption 477 478numberedFigureCaption :: PandocMonad m => Text -> Doc Text -> OD m (Doc Text) 479numberedFigureCaption ident caption = do 480 id' <- gets stImageCaptionId 481 modify (\st -> st{ stImageCaptionId = id' + 1 }) 482 capterm <- translateTerm Term.Figure 483 return $ numberedCaption "FigureCaption" capterm "Illustration" id' ident caption 484 485numberedCaption :: Text -> Text -> Text -> Int -> Text -> Doc Text -> Doc Text 486numberedCaption style term name num ident caption = 487 let t = text $ T.unpack term 488 r = num - 1 489 ident' = case ident of 490 "" -> "ref" <> name <> tshow r 491 _ -> ident 492 s = inTags False "text:sequence" [ ("text:ref-name", ident'), 493 ("text:name", name), 494 ("text:formula", "ooow:" <> name <> "+1"), 495 ("style:num-format", "1") ] $ text $ show num 496 c = text ": " 497 in inParagraphTagsWithStyle style $ hcat [ t, text " ", s, c, caption ] 498 499unNumberedCaption :: Monad m => Text -> Doc Text -> OD m (Doc Text) 500unNumberedCaption style caption = return $ inParagraphTagsWithStyle style caption 501 502colHeadsToOpenDocument :: PandocMonad m 503 => WriterOptions -> [Text] -> Ann.TableHead 504 -> OD m (Doc Text) 505colHeadsToOpenDocument o ns (Ann.TableHead _ hs) = 506 case hs of 507 [] -> return empty 508 (x:_) -> 509 let (Ann.HeaderRow _ _ c) = x 510 in inTagsIndented "table:table-header-rows" . 511 inTagsIndented "table:table-row" . 512 vcat <$> mapM (tableItemToOpenDocument o "TableHeaderRowCell") (zip ns c) 513 514tableBodyToOpenDocument:: PandocMonad m 515 => WriterOptions -> [Text] -> Ann.TableBody 516 -> OD m (Doc Text) 517tableBodyToOpenDocument o ns tb = 518 let (Ann.TableBody _ _ _ r) = tb 519 in vcat <$> mapM (tableRowToOpenDocument o ns) r 520 521tableRowToOpenDocument :: PandocMonad m 522 => WriterOptions -> [Text] -> Ann.BodyRow 523 -> OD m (Doc Text) 524tableRowToOpenDocument o ns r = 525 let (Ann.BodyRow _ _ _ c ) = r 526 in inTagsIndented "table:table-row" . vcat <$> 527 mapM (tableItemToOpenDocument o "TableRowCell") (zip ns c) 528 529colspanAttrib :: ColSpan -> [(Text, Text)] 530colspanAttrib cs = 531 case cs of 532 ColSpan 1 -> mempty 533 ColSpan n -> [("table:number-columns-spanned", tshow n)] 534 535rowspanAttrib :: RowSpan -> [(Text, Text)] 536rowspanAttrib rs = 537 case rs of 538 RowSpan 1 -> mempty 539 RowSpan n -> [("table:number-rows-spanned", tshow n)] 540 541alignAttrib :: Alignment -> [(Text,Text)] 542alignAttrib a = case a of 543 AlignRight -> ("fo:text-align","end") : style 544 AlignCenter -> ("fo:text-align","center") : style 545 _ -> [] 546 where 547 style = [("style:justify-single-word","false")] 548 549tableItemToOpenDocument :: PandocMonad m 550 => WriterOptions -> Text -> (Text,Ann.Cell) 551 -> OD m (Doc Text) 552tableItemToOpenDocument o s (n,c) = do 553 let (Ann.Cell _colspecs _colnum (Cell _ align rs cs i) ) = c 554 csa = colspanAttrib cs 555 rsa = rowspanAttrib rs 556 aa = alignAttrib align 557 a = [ ("table:style-name" , s ) 558 , ("office:value-type", "string" ) ] ++ csa ++ rsa 559 itemParaStyle <- case aa of 560 [] -> return 0 561 _ -> paraStyleFromParent n aa 562 let itemParaStyle' = case itemParaStyle of 563 0 -> n 564 x -> "P" <> tshow x 565 inTags True "table:table-cell" a <$> 566 withParagraphStyle o itemParaStyle' (map plainToPara i) 567 568-- | Convert a list of inline elements to OpenDocument. 569inlinesToOpenDocument :: PandocMonad m => WriterOptions -> [Inline] -> OD m (Doc Text) 570inlinesToOpenDocument o l = hcat <$> toChunks o l 571 572toChunks :: PandocMonad m => WriterOptions -> [Inline] -> OD m [Doc Text] 573toChunks _ [] = return [] 574toChunks o (x : xs) 575 | isChunkable x = do 576 contents <- (inTextStyle . hcat) =<< 577 mapM (inlineToOpenDocument o) (x:ys) 578 rest <- toChunks o zs 579 return (contents : rest) 580 | otherwise = do 581 contents <- inlineToOpenDocument o x 582 rest <- toChunks o xs 583 return (contents : rest) 584 where (ys, zs) = span isChunkable xs 585 586isChunkable :: Inline -> Bool 587isChunkable (Str _) = True 588isChunkable Space = True 589isChunkable SoftBreak = True 590isChunkable _ = False 591 592-- | Convert an inline element to OpenDocument. 593inlineToOpenDocument :: PandocMonad m => WriterOptions -> Inline -> OD m (Doc Text) 594inlineToOpenDocument o ils 595 = case ils of 596 Space -> return space 597 SoftBreak 598 | writerWrapText o == WrapPreserve 599 -> return $ preformatted "\n" 600 | otherwise -> return space 601 Span attr xs -> mkSpan attr xs 602 LineBreak -> return $ selfClosingTag "text:line-break" [] 603 Str s -> return $ handleSpaces $ escapeStringForXML s 604 Emph l -> withTextStyle Italic $ inlinesToOpenDocument o l 605 Underline l -> withTextStyle Under $ inlinesToOpenDocument o l 606 Strong l -> withTextStyle Bold $ inlinesToOpenDocument o l 607 Strikeout l -> withTextStyle Strike $ inlinesToOpenDocument o l 608 Superscript l -> withTextStyle Sup $ inlinesToOpenDocument o l 609 Subscript l -> withTextStyle Sub $ inlinesToOpenDocument o l 610 SmallCaps l -> withTextStyle SmallC $ inlinesToOpenDocument o l 611 Quoted t l -> inQuotes t <$> inlinesToOpenDocument o l 612 Code attrs s -> if isNothing (writerHighlightStyle o) 613 then unhighlighted s 614 else case highlight (writerSyntaxMap o) 615 formatOpenDocument attrs s of 616 Right h -> return $ mconcat $ mconcat h 617 Left msg -> do 618 unless (T.null msg) $ report $ CouldNotHighlight msg 619 unhighlighted s 620 Math t s -> lift (texMathToInlines t s) >>= 621 inlinesToOpenDocument o 622 Cite _ l -> inlinesToOpenDocument o l 623 RawInline f s -> if f == Format "opendocument" 624 then return $ text $ T.unpack s 625 else do 626 report $ InlineNotRendered ils 627 return empty 628 Link _ l (s,t) -> do 629 identTypes <- gets stIdentTypes 630 mkLink o identTypes s t <$> inlinesToOpenDocument o l 631 Image attr _ (s,t) -> mkImg attr s t 632 Note l -> mkNote l 633 where 634 formatOpenDocument :: FormatOptions -> [SourceLine] -> [[Doc Text]] 635 formatOpenDocument _fmtOpts = map (map toHlTok) 636 toHlTok :: Token -> Doc Text 637 toHlTok (toktype,tok) = 638 inTags False "text:span" [("text:style-name", T.pack $ show toktype)] $ preformatted tok 639 unhighlighted s = inlinedCode $ preformatted s 640 preformatted s = handleSpaces $ escapeStringForXML s 641 inlinedCode s = return $ inTags False "text:span" [("text:style-name", "Source_Text")] s 642 mkImg (_, _, kvs) s _ = do 643 id' <- gets stImageId 644 modify (\st -> st{ stImageId = id' + 1 }) 645 let getDims [] = [] 646 getDims (("width", w) :xs) = ("svg:width", w) : getDims xs 647 getDims (("rel-width", w):xs) = ("style:rel-width", w) : getDims xs 648 getDims (("height", h):xs) = ("svg:height", h) : getDims xs 649 getDims (("rel-height", w):xs) = ("style:rel-height", w) : getDims xs 650 getDims (_:xs) = getDims xs 651 return $ inTags False "draw:frame" 652 (("draw:name", "img" <> tshow id') : getDims kvs) $ 653 selfClosingTag "draw:image" [ ("xlink:href" , s ) 654 , ("xlink:type" , "simple") 655 , ("xlink:show" , "embed" ) 656 , ("xlink:actuate", "onLoad")] 657 mkSpan attr xs = do 658 let (ident,_,_) = attr 659 i = withLangFromAttr attr (inlinesToOpenDocument o xs) 660 mkBookmarkedSpan b = 661 if isEmpty b 662 then selfClosingBookmark ident 663 else inBookmarkTags ident b 664 if T.null ident 665 then i 666 else fmap mkBookmarkedSpan i 667 mkNote l = do 668 n <- length <$> gets stNotes 669 let footNote t = inTags False "text:note" 670 [ ("text:id" , "ftn" <> tshow n) 671 , ("text:note-class", "footnote" )] $ 672 inTagsSimple "text:note-citation" (text . show $ n + 1) <> 673 inTagsSimple "text:note-body" t 674 nn <- footNote <$> withParagraphStyle o "Footnote" l 675 addNote nn 676 return nn 677 678mkLink :: WriterOptions -> [(Text,ReferenceType)] -> Text -> Text -> Doc Text -> Doc Text 679mkLink o identTypes s t d = 680 let maybeIdentAndType = case T.uncons s of 681 Just ('#', ident) -> find ((ident ==) . fst) identTypes 682 _ -> Nothing 683 d' = inSpanTags "Definition" d 684 ref refType format ident = inTags False refType 685 [ ("text:reference-format", format ), 686 ("text:ref-name", ident) ] 687 inlineSpace = selfClosingTag "text:s" [] 688 bookmarkRef = ref "text:bookmark-ref" 689 bookmarkRefNumber ident = bookmarkRef "number" ident mempty 690 bookmarkRefName ident = bookmarkRef "text" ident d 691 bookmarkRefNameNumber ident = bookmarkRefNumber ident <> inlineSpace <> bookmarkRefName ident 692 bookmarkRef' 693 | isEnabled Ext_xrefs_number o && isEnabled Ext_xrefs_name o = bookmarkRefNameNumber 694 | isEnabled Ext_xrefs_name o = bookmarkRefName 695 | otherwise = bookmarkRefNumber 696 sequenceRef = ref "text:sequence-ref" 697 sequenceRefNumber ident = sequenceRef "value" ident mempty 698 sequenceRefName ident = sequenceRef "caption" ident d 699 sequenceRefNameNumber ident = sequenceRefNumber ident <> inlineSpace <> sequenceRefName ident 700 sequenceRef' 701 | isEnabled Ext_xrefs_number o && isEnabled Ext_xrefs_name o = sequenceRefNameNumber 702 | isEnabled Ext_xrefs_name o = sequenceRefName 703 | otherwise = sequenceRefNumber 704 link = inTags False "text:a" [ ("xlink:type" , "simple") 705 , ("xlink:href" , s ) 706 , ("office:name", t ) 707 ] d' 708 linkOrReference = case maybeIdentAndType of 709 Just (ident, HeaderRef) -> bookmarkRef' ident 710 Just (ident, TableRef) -> sequenceRef' ident 711 Just (ident, ImageRef) -> sequenceRef' ident 712 _ -> link 713 in if isEnabled Ext_xrefs_name o || isEnabled Ext_xrefs_number o 714 then linkOrReference 715 else link 716 717bulletListStyle :: PandocMonad m => Int -> OD m (Int,(Int,[Doc Text])) 718bulletListStyle l = do 719 let doStyles i = inTags True "text:list-level-style-bullet" 720 [ ("text:level" , tshow (i + 1)) 721 , ("text:style-name" , "Bullet_20_Symbols" ) 722 , ("style:num-suffix", "." ) 723 , ("text:bullet-char", T.singleton (bulletList !! i)) 724 ] (listLevelStyle (1 + i)) 725 bulletList = map chr $ cycle [8226,9702,9642] 726 listElStyle = map doStyles [0..9] 727 pn <- paraListStyle l 728 return (pn, (l, listElStyle)) 729 730orderedListLevelStyle :: ListAttributes -> (Int, [Doc Text]) -> (Int,[Doc Text]) 731orderedListLevelStyle (s,n, d) (l,ls) = 732 let suffix = case d of 733 OneParen -> [("style:num-suffix", ")")] 734 TwoParens -> [("style:num-prefix", "(") 735 ,("style:num-suffix", ")")] 736 _ -> [("style:num-suffix", ".")] 737 format = case n of 738 UpperAlpha -> "A" 739 LowerAlpha -> "a" 740 UpperRoman -> "I" 741 LowerRoman -> "i" 742 _ -> "1" 743 listStyle = inTags True "text:list-level-style-number" 744 ([ ("text:level" , tshow $ 1 + length ls ) 745 , ("text:style-name" , "Numbering_20_Symbols") 746 , ("style:num-format", format ) 747 , ("text:start-value", tshow s ) 748 ] ++ suffix) (listLevelStyle (1 + length ls)) 749 in (l, ls ++ [listStyle]) 750 751listLevelStyle :: Int -> Doc Text 752listLevelStyle i = 753 let indent = tshow (0.25 + (0.25 * fromIntegral i :: Double)) in 754 inTags True "style:list-level-properties" 755 [ ("text:list-level-position-and-space-mode", 756 "label-alignment") 757 , ("fo:text-align", "right") 758 ] $ 759 selfClosingTag "style:list-level-label-alignment" 760 [ ("text:label-followed-by", "listtab") 761 , ("text:list-tab-stop-position", indent <> "in") 762 , ("fo:text-indent", "-0.25in") 763 , ("fo:margin-left", indent <> "in") 764 ] 765 766tableStyle :: Int -> Double -> [(Char,Double)] -> Doc Text 767tableStyle num textWidth wcs = 768 let tableId = "Table" <> tshow (num + 1) 769 tableWidthAttr :: [(Text,Text)] 770 tableWidthAttr 771 | textWidth <= 1 && textWidth > 0 = [("style:rel-width", 772 T.pack (show (round (textWidth * 100) :: Int) <> "%"))] 773 | otherwise = [] 774 table = inTags True "style:style" 775 [("style:name", tableId) 776 ,("style:family", "table")] $ 777 selfClosingTag "style:table-properties" 778 (("table:align", "center") : tableWidthAttr) 779 colStyle (c,0) = selfClosingTag "style:style" 780 [ ("style:name" , tableId <> "." <> T.singleton c) 781 , ("style:family", "table-column" )] 782 colStyle (c,w) = inTags True "style:style" 783 [ ("style:name" , tableId <> "." <> T.singleton c) 784 , ("style:family", "table-column" )] $ 785 selfClosingTag "style:table-column-properties" 786 [("style:rel-column-width", T.pack $ printf "%d*" (floor $ w * 65535 :: Integer))] 787 headerRowCellStyle = inTags True "style:style" 788 [ ("style:name" , "TableHeaderRowCell") 789 , ("style:family", "table-cell" )] $ 790 selfClosingTag "style:table-cell-properties" 791 [ ("fo:border", "none")] 792 rowCellStyle = inTags True "style:style" 793 [ ("style:name" , "TableRowCell") 794 , ("style:family", "table-cell" )] $ 795 selfClosingTag "style:table-cell-properties" 796 [ ("fo:border", "none")] 797 cellStyles = if num == 0 798 then headerRowCellStyle $$ rowCellStyle 799 else empty 800 columnStyles = map colStyle wcs 801 in cellStyles $$ table $$ vcat columnStyles 802 803paraStyle :: PandocMonad m => [(Text,Text)] -> OD m Int 804paraStyle attrs = do 805 pn <- (+) 1 . length <$> gets stParaStyles 806 i <- (*) (0.5 :: Double) . fromIntegral <$> gets stIndentPara 807 b <- gets stInDefinition 808 t <- gets stTight 809 let styleAttr = [ ("style:name" , "P" <> tshow pn) 810 , ("style:family" , "paragraph" )] 811 indentVal = flip (<>) "in" . tshow $ if b then max 0.5 i else i 812 tight = if t then [ ("fo:margin-top" , "0in" ) 813 , ("fo:margin-bottom" , "0in" )] 814 else [] 815 indent = if i /= 0 || b 816 then [ ("fo:margin-left" , indentVal) 817 , ("fo:margin-right" , "0in" ) 818 , ("fo:text-indent" , "0in" ) 819 , ("style:auto-text-indent" , "false" )] 820 else [] 821 attributes = indent <> tight 822 paraProps = if null attributes 823 then mempty 824 else selfClosingTag 825 "style:paragraph-properties" attributes 826 addParaStyle $ inTags True "style:style" (styleAttr <> attrs) paraProps 827 return pn 828 829paraStyleFromParent :: PandocMonad m => Text -> [(Text,Text)] -> OD m Int 830paraStyleFromParent parent attrs = do 831 pn <- (+) 1 . length <$> gets stParaStyles 832 let styleAttr = [ ("style:name" , "P" <> tshow pn) 833 , ("style:family" , "paragraph") 834 , ("style:parent-style-name", parent)] 835 paraProps = if null attrs 836 then mempty 837 else selfClosingTag 838 "style:paragraph-properties" attrs 839 addParaStyle $ inTags True "style:style" styleAttr paraProps 840 return pn 841 842 843paraListStyle :: PandocMonad m => Int -> OD m Int 844paraListStyle l = paraStyle 845 [("style:parent-style-name","Text_20_body") 846 ,("style:list-style-name", "L" <> tshow l)] 847 848paraTableStyles :: Text -> Int -> [Alignment] -> [(Text, Doc Text)] 849paraTableStyles _ _ [] = [] 850paraTableStyles t s (a:xs) 851 | AlignRight <- a = ( pName s, res s "end" ) : paraTableStyles t (s + 1) xs 852 | AlignCenter <- a = ( pName s, res s "center") : paraTableStyles t (s + 1) xs 853 | otherwise = ("Table_20_" <> t, empty ) : paraTableStyles t s xs 854 where pName sn = "P" <> tshow (sn + 1) 855 res sn x = inTags True "style:style" 856 [ ("style:name" , pName sn ) 857 , ("style:family" , "paragraph" ) 858 , ("style:parent-style-name", "Table_20_" <> t)] $ 859 selfClosingTag "style:paragraph-properties" 860 [ ("fo:text-align", x) 861 , ("style:justify-single-word", "false")] 862 863data TextStyle = Italic 864 | Bold 865 | Under 866 | Strike 867 | Sub 868 | Sup 869 | SmallC 870 | Pre 871 | Language Lang 872 deriving ( Eq,Ord ) 873 874textStyleAttr :: Map.Map Text Text 875 -> TextStyle 876 -> Map.Map Text Text 877textStyleAttr m s 878 | Italic <- s = Map.insert "fo:font-style" "italic" . 879 Map.insert "style:font-style-asian" "italic" . 880 Map.insert "style:font-style-complex" "italic" $ m 881 | Bold <- s = Map.insert "fo:font-weight" "bold" . 882 Map.insert "style:font-weight-asian" "bold" . 883 Map.insert "style:font-weight-complex" "bold" $ m 884 | Under <- s = Map.insert "style:text-underline-style" "solid" . 885 Map.insert "style:text-underline-width" "auto" . 886 Map.insert "style:text-underline-color" "font-color" $ m 887 | Strike <- s = Map.insert "style:text-line-through-style" "solid" m 888 | Sub <- s = Map.insert "style:text-position" "sub 58%" m 889 | Sup <- s = Map.insert "style:text-position" "super 58%" m 890 | SmallC <- s = Map.insert "fo:font-variant" "small-caps" m 891 | Pre <- s = Map.insert "style:font-name" "Courier New" . 892 Map.insert "style:font-name-asian" "Courier New" . 893 Map.insert "style:font-name-complex" "Courier New" $ m 894 | Language lang <- s 895 = Map.insert "fo:language" (langLanguage lang) . 896 Map.insert "fo:country" (langRegion lang) $ m 897 | otherwise = m 898 899withLangFromAttr :: PandocMonad m => Attr -> OD m a -> OD m a 900withLangFromAttr (_,_,kvs) action = 901 case lookup "lang" kvs of 902 Nothing -> action 903 Just l -> 904 case parseBCP47 l of 905 Right lang -> withTextStyle (Language lang) action 906 Left _ -> do 907 report $ InvalidLang l 908 action 909