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