e683707 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Improve the parsing of frames in ODT documents

e683707blmage7 years ago

src/Text/Pandoc/Readers/Odt.hs+2−3

compare with master

unifiedsplit

@@ -86,9 +86,8 @@ archiveToOdt archive

86 where

87 filePathIsOdtMedia :: FilePath -> Bool

88 filePathIsOdtMedia fp =

89− let (dir, _) = splitFileName fp

89+ let (dir, name) = splitFileName fp

90− in

91− (dir == "Pictures/")

90+ in (dir == "Pictures/") || (dir /= "./" && name == "content.xml")

94--

93--

src/Text/Pandoc/Readers/Odt/ContentReader.hs+74−48

@@ -1,5 +1,7 @@

1{-# LANGUAGE NoImplicitPrelude #-}

2{-# LANGUAGE Arrows #-}

3+{-# LANGUAGE DeriveFoldable #-}

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE PatternGuards #-}

5{-# LANGUAGE PatternGuards #-}

4{-# LANGUAGE RecordWildCards #-}

6{-# LANGUAGE RecordWildCards #-}

5{-# LANGUAGE TupleSections #-}

7{-# LANGUAGE TupleSections #-}

@@ -26,21 +28,26 @@ import Control.Applicative hiding (liftA, liftA2, liftA3)

26import Control.Arrow

28import Control.Arrow

28import qualified Data.ByteString.Lazy as B

30import qualified Data.ByteString.Lazy as B

31+import Data.Foldable (fold)

29−import Data.List (find, intercalate)

32+import Data.List (find, intercalate, stripPrefix)

30import qualified Data.Map as M

33import qualified Data.Map as M

31import Data.Maybe

34import Data.Maybe

35+import Data.Semigroup (First(..), Option(..))

37+import Text.TeXMath (readMathML, writeTeX)

33import qualified Text.XML.Light as XML

38import qualified Text.XML.Light as XML

35import Text.Pandoc.Builder

40import Text.Pandoc.Builder

36import Text.Pandoc.MediaBag (MediaBag, insertMedia)

41import Text.Pandoc.MediaBag (MediaBag, insertMedia)

37import Text.Pandoc.Shared

42import Text.Pandoc.Shared

38import Text.Pandoc.Extensions (extensionsFromList, Extension(..))

43import Text.Pandoc.Extensions (extensionsFromList, Extension(..))

44+import qualified Text.Pandoc.UTF8 as UTF8

40import Text.Pandoc.Readers.Odt.Base

46import Text.Pandoc.Readers.Odt.Base

41import Text.Pandoc.Readers.Odt.Namespaces

47import Text.Pandoc.Readers.Odt.Namespaces

42import Text.Pandoc.Readers.Odt.StyleReader

48import Text.Pandoc.Readers.Odt.StyleReader

50+import Text.Pandoc.Readers.Odt.Arrows.State (foldS)

44import Text.Pandoc.Readers.Odt.Arrows.Utils

51import Text.Pandoc.Readers.Odt.Arrows.Utils

45import Text.Pandoc.Readers.Odt.Generic.Fallible

52import Text.Pandoc.Readers.Odt.Generic.Fallible

46import Text.Pandoc.Readers.Odt.Generic.Utils

53import Text.Pandoc.Readers.Odt.Generic.Utils

@@ -498,6 +505,13 @@ type InlineMatcher = ElementMatcher Inlines

498type BlockMatcher = ElementMatcher Blocks

505type BlockMatcher = ElementMatcher Blocks

499

506

500

507

508+newtype FirstMatch a = FirstMatch (Option (First a))

509+ deriving (Foldable, Monoid, Semigroup)

510+

511+firstMatch :: a -> FirstMatch a

512+firstMatch = FirstMatch . Option . Just . First

513+

514+

501--

515--

502matchingElement :: (Monoid e)

516matchingElement :: (Monoid e)

503 => Namespace -> ElementName

517 => Namespace -> ElementName

@@ -598,7 +612,7 @@ read_paragraph = matchingElement NsText "p"

598 , read_reference_start

612 , read_reference_start

599 , read_bookmark_ref

613 , read_bookmark_ref

600 , read_reference_ref

614 , read_reference_ref

601− , read_maybe_nested_img_frame

615+ , read_frame

602 , read_text_seq

616 , read_text_seq

603 ] read_plain_text

617 ] read_plain_text

604

618

@@ -624,7 +638,7 @@ read_header = matchingElement NsText "h"

624 , read_reference_start

638 , read_reference_start

625 , read_bookmark_ref

639 , read_bookmark_ref

626 , read_reference_ref

640 , read_reference_ref

627− , read_maybe_nested_img_frame

641+ , read_frame

628 ] read_plain_text

642 ] read_plain_text

629 ) -< blocks

643 ) -< blocks

630 anchor <- getHeaderAnchor -< children

644 anchor <- getHeaderAnchor -< children

@@ -737,32 +751,43 @@ read_table_cell = matchingElement NsTable "table-cell"

737 ]

751 ]

738

752

739----------------------

753----------------------

740−-- Images

754+-- Frames

741----------------------

755----------------------

742

756

743--

757--

744−read_maybe_nested_img_frame :: InlineMatcher

758+read_frame :: InlineMatcher

745−read_maybe_nested_img_frame = matchingElement NsDraw "frame"

759+read_frame = matchingElement NsDraw "frame"

746− $ proc blocks -> do

760+ $ filterChildrenName' NsDraw (`elem` ["image", "object", "text-box"])

747− img <- (findChild' NsDraw "image") -< ()

761+ >>> foldS read_frame_child

748− case img of

762+ >>> arr fold

749− Just _ -> read_frame -< blocks

763+

764+read_frame_child :: OdtReaderSafe XML.Element (FirstMatch Inlines)

765+read_frame_child =

766+ proc child -> case elName child of

767+ "image" -> read_frame_img -< child

768+ "object" -> read_frame_mathml -< child

750− Nothing -> matchChildContent' [ read_frame_text_box ] -< blocks

769+ "text-box" -> read_frame_text_box -< child

751−

770+ _ -> returnV mempty -< ()

771+

752−read_frame :: OdtReaderSafe Inlines Inlines

772+read_frame_img :: OdtReaderSafe XML.Element (FirstMatch Inlines)

753−read_frame =

773+read_frame_img =

754− proc blocks -> do

774+ proc img -> do

775+ src <- executeIn (findAttr' NsXLink "href") -< img

776+ case fold src of

777+ "" -> returnV mempty -< ()

778+ src' -> do

755− let exts = extensionsFromList [Ext_auto_identifiers]

779+ let exts = extensionsFromList [Ext_auto_identifiers]

780+ resource <- lookupResource -< src'

781+ _ <- updateMediaWithResource -< resource

756− w <- ( findAttr' NsSVG "width" ) -< ()

782+ w <- findAttr' NsSVG "width" -< ()

757− h <- ( findAttr' NsSVG "height" ) -< ()

783+ h <- findAttr' NsSVG "height" -< ()

758− titleNodes <- ( matchChildContent' [ read_frame_title ] ) -< blocks

784+ titleNodes <- matchChildContent' [ read_frame_title ] -< ()

759− src <- matchChildContent' [ read_image_src ] -< blocks

760− resource <- lookupResource -< src

761− _ <- updateMediaWithResource -< resource

762− alt <- (matchChildContent [] read_plain_text) -< blocks

785+ alt <- matchChildContent [] read_plain_text -< ()

763− arr (uncurry4 imageWith ) -<

786+ arr (firstMatch . uncurry4 imageWith) -<

764− (image_attributes w h, src,

765− inlineListToIdentifier exts (toList titleNodes), alt)

787+ (image_attributes w h, src', inlineListToIdentifier exts (toList titleNodes), alt)

788+

789+read_frame_title :: InlineMatcher

790+read_frame_title = matchingElement NsSVG "title" (matchChildContent [] read_plain_text)

766

791

767image_attributes :: Maybe String -> Maybe String -> Attr

792image_attributes :: Maybe String -> Maybe String -> Attr

768image_attributes x y =

793image_attributes x y =

@@ -772,28 +797,29 @@ image_attributes x y =

772 dim name (Just v) = [(name, v)]

797 dim name (Just v) = [(name, v)]

773 dim _ Nothing = []

798 dim _ Nothing = []

774

799

775−read_image_src :: (Namespace, ElementName, OdtReader Anchor Anchor)

800+read_frame_mathml :: OdtReaderSafe XML.Element (FirstMatch Inlines)

776−read_image_src = matchingElement NsDraw "image"

801+read_frame_mathml =

777− $ proc _ -> do

802+ proc obj -> do

778− imgSrc <- findAttr NsXLink "href" -< ()

803+ src <- executeIn (findAttr' NsXLink "href") -< obj

779− case imgSrc of

804+ case fold src of

780− Right src -> returnV src -<< ()

805+ "" -> returnV mempty -< ()

806+ src' -> do

807+ let path = fromMaybe src' (stripPrefix "./" src') ++ "/content.xml"

808+ (_, mathml) <- lookupResource -< path

809+ case readMathML (UTF8.toString $ B.toStrict mathml) of

781− Left _ -> returnV "" -< ()

810+ Left _ -> returnV mempty -< ()

782−

811+ Right exps -> arr (firstMatch . displayMath . writeTeX) -< exps

783−read_frame_title :: InlineMatcher

812+

784−read_frame_title = matchingElement NsSVG "title" (matchChildContent [] read_plain_text)

785−

786−read_frame_text_box :: InlineMatcher

813+read_frame_text_box :: OdtReaderSafe XML.Element (FirstMatch Inlines)

787−read_frame_text_box = matchingElement NsDraw "text-box"

814+read_frame_text_box = proc box -> do

788− $ proc blocks -> do

789− paragraphs <- (matchChildContent' [ read_paragraph ]) -< blocks

815+ paragraphs <- executeIn (matchChildContent' [ read_paragraph ]) -< box

790− arr read_img_with_caption -< toList paragraphs

816+ arr read_img_with_caption -< toList paragraphs

791−

817+

792−read_img_with_caption :: [Block] -> Inlines

818+read_img_with_caption :: [Block] -> FirstMatch Inlines

793read_img_with_caption (Para [Image attr alt (src,title)] : _) =

819read_img_with_caption (Para [Image attr alt (src,title)] : _) =

794− singleton (Image attr alt (src, 'f':'i':'g':':':title)) -- no text, default caption

820+ firstMatch $ singleton (Image attr alt (src, 'f':'i':'g':':':title)) -- no text, default caption

795read_img_with_caption (Para (Image attr _ (src,title) : txt) : _) =

821read_img_with_caption (Para (Image attr _ (src,title) : txt) : _) =

796− singleton (Image attr txt (src, 'f':'i':'g':':':title) ) -- override caption with the text that follows

822+ firstMatch $ singleton (Image attr txt (src, 'f':'i':'g':':':title) ) -- override caption with the text that follows

797read_img_with_caption ( Para (_ : xs) : ys) =

823read_img_with_caption ( Para (_ : xs) : ys) =

798 read_img_with_caption (Para xs : ys)

824 read_img_with_caption (Para xs : ys)

799read_img_with_caption _ =

825read_img_with_caption _ =

@@ -901,8 +927,8 @@ post_process' (Table _ a w h r : Div ("", ["caption"], _) [Para inlines] : xs) =

901post_process' bs = bs

927post_process' bs = bs

902

928

903read_body :: OdtReader _x (Pandoc, MediaBag)

929read_body :: OdtReader _x (Pandoc, MediaBag)

904−read_body = executeIn NsOffice "body"

930+read_body = executeInSub NsOffice "body"

905− $ executeIn NsOffice "text"

931+ $ executeInSub NsOffice "text"

906 $ liftAsSuccess

932 $ liftAsSuccess

907 $ proc inlines -> do

933 $ proc inlines -> do

908 txt <- read_text -< inlines

934 txt <- read_text -< inlines

src/Text/Pandoc/Readers/Odt/Generic/XMLConverter.hs+46−19

@@ -29,8 +29,10 @@ module Text.Pandoc.Readers.Odt.Generic.XMLConverter

29, modifyExtraState

30, producingExtraState

31, findChild'

32+, filterChildrenName'

32, isSet'

33, isSet'

33, isSetWithDefault

34, isSetWithDefault

35+, elName

34, searchAttr

36, searchAttr

35, lookupAttr

37, lookupAttr

36, lookupAttr'

38, lookupAttr'

@@ -43,6 +45,7 @@ module Text.Pandoc.Readers.Odt.Generic.XMLConverter

43, readAttrWithDefault

45, readAttrWithDefault

44, getAttr

46, getAttr

45, executeIn

47, executeIn

48+, executeInSub

46, withEveryL

49, withEveryL

47, tryAll

50, tryAll

48, matchContent'

51, matchContent'

@@ -309,34 +312,44 @@ readNSattributes = fromState $ \state -> maybe (state, failEmpty )

309

312

310-- | Given a namespace id and an element name, creates a 'XML.QName' for

313-- | Given a namespace id and an element name, creates a 'XML.QName' for

311-- internal use

314-- internal use

312−elemName :: (NameSpaceID nsID)

315+qualifyName :: (NameSpaceID nsID)

313 => nsID -> ElementName

316 => nsID -> ElementName

314 -> XMLConverter nsID extraState x XML.QName

317 -> XMLConverter nsID extraState x XML.QName

315−elemName nsID name = lookupNSiri nsID

318+qualifyName nsID name = lookupNSiri nsID

316 &&& lookupNSprefix nsID

319 &&& lookupNSprefix nsID

317 >>% XML.QName name

320 >>% XML.QName name

318

321

322+-- | Checks if a given element matches both a specified namespace id

323+-- and a predicate

324+elemNameMatches :: (NameSpaceID nsID)

325+ => nsID -> (ElementName -> Bool)

326+ -> XMLConverter nsID extraState XML.Element Bool

327+elemNameMatches nsID f = keepingTheValue (lookupNSiri nsID) >>% hasMatchingName

328+ where hasMatchingName e iri = let name = XML.elName e

329+ in f (XML.qName name)

330+ && XML.qURI name == iri

331+

319-- | Checks if a given element matches both a specified namespace id

332-- | Checks if a given element matches both a specified namespace id

320-- and a specified element name

333-- and a specified element name

321elemNameIs :: (NameSpaceID nsID)

334elemNameIs :: (NameSpaceID nsID)

322 => nsID -> ElementName

335 => nsID -> ElementName

323 -> XMLConverter nsID extraState XML.Element Bool

336 -> XMLConverter nsID extraState XML.Element Bool

324−elemNameIs nsID name = keepingTheValue (lookupNSiri nsID) >>% hasThatName

337+elemNameIs nsID name = elemNameMatches nsID (== name)

325− where hasThatName e iri = let elName = XML.elName e

326− in XML.qName elName == name

327− && XML.qURI elName == iri

328

338

329--------------------------------------------------------------------------------

339--------------------------------------------------------------------------------

330-- General content

340-- General content

331--------------------------------------------------------------------------------

341--------------------------------------------------------------------------------

332

342

343+elName :: XML.Element -> ElementName

344+elName = XML.qName . XML.elName

345+

333--

346--

334elContent :: XMLConverter nsID extraState x [XML.Content]

347elContent :: XMLConverter nsID extraState x [XML.Content]

335elContent = getCurrentElement

348elContent = getCurrentElement

336 >>^ XML.elContent

349 >>^ XML.elContent

337

350

338--------------------------------------------------------------------------------

351--------------------------------------------------------------------------------

339−-- Chilren

352+-- Children

340--------------------------------------------------------------------------------

353--------------------------------------------------------------------------------

341

354

342--

355--

@@ -344,7 +357,7 @@ elContent = getCurrentElement

344findChildren :: (NameSpaceID nsID)

357findChildren :: (NameSpaceID nsID)

345 => nsID -> ElementName

358 => nsID -> ElementName

346 -> XMLConverter nsID extraState x [XML.Element]

359 -> XMLConverter nsID extraState x [XML.Element]

347−findChildren nsID name = elemName nsID name

360+findChildren nsID name = qualifyName nsID name

348 &&& getCurrentElement

361 &&& getCurrentElement

349 >>% XML.findChildren

362 >>% XML.findChildren

350

363

@@ -353,7 +366,7 @@ findChild' :: (NameSpaceID nsID)

353 => nsID

366 => nsID

354 -> ElementName

367 -> ElementName

355 -> XMLConverter nsID extraState x (Maybe XML.Element)

368 -> XMLConverter nsID extraState x (Maybe XML.Element)

356−findChild' nsID name = elemName nsID name

369+findChild' nsID name = qualifyName nsID name

357 &&& getCurrentElement

370 &&& getCurrentElement

358 >>% XML.findChild

371 >>% XML.findChild

359

372

@@ -364,6 +377,14 @@ findChild :: (NameSpaceID nsID)

364findChild nsID name = findChild' nsID name

377findChild nsID name = findChild' nsID name

365 >>> maybeToChoice

378 >>> maybeToChoice

366

379

380+filterChildrenName' :: (NameSpaceID nsID)

381+ => nsID

382+ -> (ElementName -> Bool)

383+ -> XMLConverter nsID extraState x [XML.Element]

384+filterChildrenName' nsID f = getCurrentElement

385+ >>> arr XML.elChildren

386+ >>> iterateS (keepingTheValue (elemNameMatches nsID f))

387+ >>> arr (catMaybes . fmap (uncurry $ bool Nothing . Just))

367

388

368--------------------------------------------------------------------------------

389--------------------------------------------------------------------------------

369-- Attributes

390-- Attributes

@@ -441,7 +462,7 @@ lookupDefaultingAttr nsID attrName

441findAttr' :: (NameSpaceID nsID)

462findAttr' :: (NameSpaceID nsID)

442 => nsID -> AttributeName

463 => nsID -> AttributeName

443 -> XMLConverter nsID extraState x (Maybe AttributeValue)

464 -> XMLConverter nsID extraState x (Maybe AttributeValue)

444−findAttr' nsID attrName = elemName nsID attrName

465+findAttr' nsID attrName = qualifyName nsID attrName

445 &&& getCurrentElement

466 &&& getCurrentElement

446 >>% XML.findAttr

467 >>% XML.findAttr

447

468

@@ -537,15 +558,21 @@ executeThere a = second jumpThere

537 >>> jumpBack -- >>? jumpBack would not ensure the jump.

558 >>> jumpBack -- >>? jumpBack would not ensure the jump.

538 >>^ collapseEither

559 >>^ collapseEither

539

560

561+

562+-- | Do something in a specific element, then come back

563+executeIn :: XMLConverter nsID extraState XML.Element s

564+ -> XMLConverter nsID extraState XML.Element s

565+executeIn a = duplicate >>> switchingTheStack a

566+

540−-- | Do something in a sub-element, tnen come back

567+-- | Do something in a sub-element, then come back

541−executeIn :: (NameSpaceID nsID)

568+executeInSub :: (NameSpaceID nsID)

542− => nsID -> ElementName

569+ => nsID -> ElementName

543− -> FallibleXMLConverter nsID extraState f s

570+ -> FallibleXMLConverter nsID extraState f s

544− -> FallibleXMLConverter nsID extraState f s

571+ -> FallibleXMLConverter nsID extraState f s

545−executeIn nsID name a = keepingTheValue

572+executeInSub nsID name a = keepingTheValue

546− (findChild nsID name)

573+ (findChild nsID name)

547− >>> ignoringState liftFailure

574+ >>> ignoringState liftFailure

548− >>? switchingTheStack a

575+ >>? switchingTheStack a

549 where liftFailure (_, (Left f)) = Left f

576 where liftFailure (_, (Left f)) = Left f

550 liftFailure (x, (Right e)) = Right (x, e)

577 liftFailure (x, (Right e)) = Right (x, e)

551

578

src/Text/Pandoc/Readers/Odt/StyleReader.hs+5−5

@@ -113,7 +113,7 @@ type StyleReaderSafe a b = XMLReaderSafe FontPitches a b

113

114-- | A reader for font pitches

115fontPitchReader :: XMLReader _s _x FontPitches

116−fontPitchReader = executeIn NsOffice "font-face-decls" (

116+fontPitchReader = executeInSub NsOffice "font-face-decls" (

117 withEveryL NsStyle "font-face" (liftAsSuccess (

118 findAttr' NsStyle "name"

119 &&&

@@ -423,7 +423,7 @@ readAllStyles = ( readFontPitches

423

424--

425readStyles :: StyleReader _x Styles

426−readStyles = executeIn NsOffice "styles" $ liftAsSuccess

426+readStyles = executeInSub NsOffice "styles" $ liftAsSuccess

427 $ liftA3 Styles

428 ( tryAll NsStyle "style" readStyle >>^ M.fromList )

429 ( tryAll NsText "list-style" readListStyle >>^ M.fromList )

@@ -431,7 +431,7 @@ readStyles = executeIn NsOffice "styles" $ liftAsSuccess

431

432--

433readAutomaticStyles :: StyleReader _x Styles

434−readAutomaticStyles = executeIn NsOffice "automatic-styles" $ liftAsSuccess

434+readAutomaticStyles = executeInSub NsOffice "automatic-styles" $ liftAsSuccess

435 $ liftA3 Styles

436 ( tryAll NsStyle "style" readStyle >>^ M.fromList )

437 ( tryAll NsText "list-style" readListStyle >>^ M.fromList )

@@ -462,7 +462,7 @@ readStyleProperties = liftA2 SProps

462--

463readTextProperties :: StyleReader _x TextProperties

464readTextProperties =

465− executeIn NsStyle "text-properties" $ liftAsSuccess

465+ executeInSub NsStyle "text-properties" $ liftAsSuccess

466 ( liftA6 PropT

467 ( searchAttr NsXSL_FO "font-style" False isFontEmphasised )

468 ( searchAttr NsXSL_FO "font-weight" False isFontBold )

@@ -501,7 +501,7 @@ readLineMode modeAttr styleAttr = proc x -> do

501--

502readParaProperties :: StyleReader _x ParaProperties

503readParaProperties =

504− executeIn NsStyle "paragraph-properties" $ liftAsSuccess

504+ executeInSub NsStyle "paragraph-properties" $ liftAsSuccess

505 ( liftA3 PropP

506 ( liftA2 readNumbering

507 ( isSet' NsText "number-lines" )