aboutsummaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Readers/Odt/ContentReader.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/Pandoc/Readers/Odt/ContentReader.hs')
-rw-r--r--src/Text/Pandoc/Readers/Odt/ContentReader.hs790
1 files changed, 790 insertions, 0 deletions
diff --git a/src/Text/Pandoc/Readers/Odt/ContentReader.hs b/src/Text/Pandoc/Readers/Odt/ContentReader.hs
new file mode 100644
index 000000000..9bb585b8e
--- /dev/null
+++ b/src/Text/Pandoc/Readers/Odt/ContentReader.hs
@@ -0,0 +1,790 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+
+{-
+Copyright (C) 2015 Martin Linnemann <theCodingMarlin@googlemail.com>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+-}
+
+{- |
+ Module : Text.Pandoc.Readers.Odt.ContentReader
+ Copyright : Copyright (C) 2015 Martin Linnemann
+ License : GNU GPL, version 2 or above
+
+ Maintainer : Martin Linnemann <theCodingMarlin@googlemail.com>
+ Stability : alpha
+ Portability : portable
+
+The core of the odt reader that converts odt features into Pandoc types.
+-}
+
+module Text.Pandoc.Readers.Odt.ContentReader
+( readerState
+, read_body
+) where
+
+import Control.Arrow
+import Control.Applicative hiding ( liftA, liftA2, liftA3 )
+
+import qualified Data.Map as M
+import Data.List ( find )
+import Data.Monoid
+import Data.Maybe
+
+import qualified Text.XML.Light as XML
+
+import Text.Pandoc.Definition
+import Text.Pandoc.Builder
+import Text.Pandoc.Shared
+
+import Text.Pandoc.Readers.Odt.Base
+import Text.Pandoc.Readers.Odt.Namespaces
+import Text.Pandoc.Readers.Odt.StyleReader
+
+import Text.Pandoc.Readers.Odt.Arrows.Utils
+import Text.Pandoc.Readers.Odt.Generic.XMLConverter
+import Text.Pandoc.Readers.Odt.Generic.Fallible
+import Text.Pandoc.Readers.Odt.Generic.Utils
+
+
+--------------------------------------------------------------------------------
+-- State
+--------------------------------------------------------------------------------
+
+type Anchor = String
+
+data ReaderState
+ = ReaderState { -- | A collection of styles read somewhere else.
+ -- It is only queried here, not modified.
+ styleSet :: Styles
+ -- | A stack of the styles of parent elements.
+ -- Used to look up inherited style properties.
+ , styleTrace :: [Style]
+ -- | Keeps track of the current depth in nested lists
+ , currentListLevel :: ListLevel
+ -- | Lists may provide their own style, but they don't have
+ -- to. If they do not, the style of a parent list may be used
+ -- or even a default list style from the paragraph style.
+ -- This value keeps track of the closest list style there
+ -- currently is.
+ , currentListStyle :: Maybe ListStyle
+ -- | A map from internal anchor names to "pretty" ones.
+ -- The mapping is a purely cosmetic one.
+ , bookmarkAnchors :: M.Map Anchor Anchor
+
+-- , sequences
+-- , trackedChangeIDs
+ }
+ deriving ( Show )
+
+readerState :: Styles -> ReaderState
+readerState styles = ReaderState styles [] 0 Nothing M.empty
+
+--
+pushStyle' :: Style -> ReaderState -> ReaderState
+pushStyle' style state = state { styleTrace = style : styleTrace state }
+
+--
+popStyle' :: ReaderState -> ReaderState
+popStyle' state = case styleTrace state of
+ _:trace -> state { styleTrace = trace }
+ _ -> state
+
+--
+modifyListLevel :: (ListLevel -> ListLevel) -> (ReaderState -> ReaderState)
+modifyListLevel f state = state { currentListLevel = f (currentListLevel state) }
+
+--
+shiftListLevel :: ListLevel -> (ReaderState -> ReaderState)
+shiftListLevel diff = modifyListLevel (+ diff)
+
+--
+swapCurrentListStyle :: Maybe ListStyle -> ReaderState
+ -> (ReaderState, Maybe ListStyle)
+swapCurrentListStyle mListStyle state = ( state { currentListStyle = mListStyle }
+ , currentListStyle state
+ )
+
+--
+lookupPrettyAnchor :: Anchor -> ReaderState -> Maybe Anchor
+lookupPrettyAnchor anchor ReaderState{..} = M.lookup anchor bookmarkAnchors
+
+--
+putPrettyAnchor :: Anchor -> Anchor -> ReaderState -> ReaderState
+putPrettyAnchor ugly pretty state@ReaderState{..}
+ = state { bookmarkAnchors = M.insert ugly pretty bookmarkAnchors }
+
+--
+usedAnchors :: ReaderState -> [Anchor]
+usedAnchors ReaderState{..} = M.elems bookmarkAnchors
+
+--------------------------------------------------------------------------------
+-- Reader type and associated tools
+--------------------------------------------------------------------------------
+
+type OdtReader a b = XMLReader ReaderState a b
+
+type OdtReaderSafe a b = XMLReaderSafe ReaderState a b
+
+-- | Extract something from the styles
+fromStyles :: (a -> Styles -> b) -> OdtReaderSafe a b
+fromStyles f = keepingTheValue
+ (getExtraState >>^ styleSet)
+ >>§ f
+
+--
+getStyleByName :: OdtReader StyleName Style
+getStyleByName = fromStyles lookupStyle >>^ maybeToChoice
+
+--
+findStyleFamily :: OdtReader Style StyleFamily
+findStyleFamily = fromStyles getStyleFamily >>^ maybeToChoice
+
+--
+lookupListStyle :: OdtReader StyleName ListStyle
+lookupListStyle = fromStyles lookupListStyleByName >>^ maybeToChoice
+
+--
+switchCurrentListStyle :: OdtReaderSafe (Maybe ListStyle) (Maybe ListStyle)
+switchCurrentListStyle = keepingTheValue getExtraState
+ >>§ swapCurrentListStyle
+ >>> first setExtraState
+ >>^ snd
+
+--
+pushStyle :: OdtReaderSafe Style Style
+pushStyle = keepingTheValue (
+ ( keepingTheValue getExtraState
+ >>§ pushStyle'
+ )
+ >>> setExtraState
+ )
+ >>^ fst
+
+--
+popStyle :: OdtReaderSafe x x
+popStyle = keepingTheValue (
+ getExtraState
+ >>> arr popStyle'
+ >>> setExtraState
+ )
+ >>^ fst
+
+--
+getCurrentListLevel :: OdtReaderSafe _x ListLevel
+getCurrentListLevel = getExtraState >>^ currentListLevel
+
+
+type AnchorPrefix = String
+
+-- | An adaptation of 'uniqueIdent' from "Text.Pandoc.Shared" that generates a
+-- unique identifier but without assuming that the id should be for a header.
+-- Second argument is a list of already used identifiers.
+uniqueIdentFrom :: AnchorPrefix -> [Anchor] -> Anchor
+uniqueIdentFrom baseIdent usedIdents =
+ let numIdent n = baseIdent ++ "-" ++ show n
+ in if baseIdent `elem` usedIdents
+ then case find (\x -> numIdent x `notElem` usedIdents) ([1..60000] :: [Int]) of
+ Just x -> numIdent x
+ Nothing -> baseIdent -- if we have more than 60,000, allow repeats
+ else baseIdent
+
+-- | First argument: basis for a new "pretty" anchor if none exists yet
+-- Second argument: a key ("ugly" anchor)
+-- Returns: saved "pretty" anchor or created new one
+getPrettyAnchor :: OdtReaderSafe (AnchorPrefix, Anchor) Anchor
+getPrettyAnchor = proc (baseIdent, uglyAnchor) -> do
+ state <- getExtraState -< ()
+ case lookupPrettyAnchor uglyAnchor state of
+ Just prettyAnchor -> returnA -< prettyAnchor
+ Nothing -> do
+ let newPretty = uniqueIdentFrom baseIdent (usedAnchors state)
+ modifyExtraState (putPrettyAnchor uglyAnchor newPretty) -<< newPretty
+
+-- | Input: basis for a new header anchor
+-- Ouput: saved new anchor
+getHeaderAnchor :: OdtReaderSafe Inlines Anchor
+getHeaderAnchor = proc title -> do
+ state <- getExtraState -< ()
+ let anchor = uniqueIdent (toList title) (usedAnchors state)
+ modifyExtraState (putPrettyAnchor anchor anchor) -<< anchor
+
+
+--------------------------------------------------------------------------------
+-- Working with styles
+--------------------------------------------------------------------------------
+
+--
+readStyleByName :: OdtReader _x Style
+readStyleByName = findAttr NsText "style-name" >>? getStyleByName
+
+--
+isStyleToTrace :: OdtReader Style Bool
+isStyleToTrace = findStyleFamily >>?^ (==FaText)
+
+--
+withNewStyle :: OdtReaderSafe x Inlines -> OdtReaderSafe x Inlines
+withNewStyle a = proc x -> do
+ fStyle <- readStyleByName -< ()
+ case fStyle of
+ Right style -> do
+ mFamily <- arr styleFamily -< style
+ fTextProps <- arr ( maybeToChoice
+ . textProperties
+ . styleProperties
+ ) -< style
+ case fTextProps of
+ Right textProps -> do
+ state <- getExtraState -< ()
+ let triple = (state, textProps, mFamily)
+ modifier <- arr modifierFromStyleDiff -< triple
+ fShouldTrace <- isStyleToTrace -< style
+ case fShouldTrace of
+ Right shouldTrace -> do
+ if shouldTrace
+ then do
+ pushStyle -< style
+ inlines <- a -< x
+ popStyle -< ()
+ arr modifier -<< inlines
+ else
+ -- In case anything goes wrong
+ a -< x
+ Left _ -> a -< x
+ Left _ -> a -< x
+ Left _ -> a -< x
+
+
+type PropertyTriple = (ReaderState, TextProperties, Maybe StyleFamily)
+type InlineModifier = Inlines -> Inlines
+
+-- | Given data about the local style changes, calculates how to modify
+-- an instance of 'Inlines'
+modifierFromStyleDiff :: PropertyTriple -> InlineModifier
+modifierFromStyleDiff propertyTriple =
+ composition $
+ (getVPosModifier propertyTriple)
+ : map (first ($ propertyTriple) >>> ifThen_else ignore)
+ [ (hasEmphChanged , emph )
+ , (hasChanged isStrong , strong )
+ , (hasChanged strikethrough , strikeout )
+ ]
+ where
+ ifThen_else else' (if',then') = if if' then then' else else'
+
+ ignore = id :: InlineModifier
+
+ getVPosModifier :: PropertyTriple -> InlineModifier
+ getVPosModifier triple@(_,textProps,_) =
+ let getVPos = Just . verticalPosition
+ in case lookupPreviousValueM getVPos triple of
+ Nothing -> ignore
+ Just oldVPos -> getVPosModifier' (oldVPos,verticalPosition textProps)
+
+ getVPosModifier' (oldVPos , newVPos ) | oldVPos == newVPos = ignore
+ getVPosModifier' ( _ , VPosSub ) = subscript
+ getVPosModifier' ( _ , VPosSuper ) = superscript
+ getVPosModifier' ( _ , _ ) = ignore
+
+ hasEmphChanged :: PropertyTriple -> Bool
+ hasEmphChanged = swing any [ hasChanged isEmphasised
+ , hasChangedM pitch
+ , hasChanged underline
+ ]
+
+ hasChanged property triple@(_, property -> newProperty, _) =
+ maybe True (/=newProperty) (lookupPreviousValue property triple)
+
+ hasChangedM property triple@(_, textProps,_) =
+ fromMaybe False $ (/=) <$> property textProps <*> lookupPreviousValueM property triple
+
+ lookupPreviousValue f = lookupPreviousStyleValue ((fmap f).textProperties)
+
+ lookupPreviousValueM f = lookupPreviousStyleValue ((f =<<).textProperties)
+
+ lookupPreviousStyleValue f (ReaderState{..},_,mFamily)
+ = ( findBy f $ extendedStylePropertyChain styleTrace styleSet )
+ <|> ( f =<< fmap (lookupDefaultStyle' styleSet) mFamily )
+
+
+type ParaModifier = Blocks -> Blocks
+
+_MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_ :: Int
+_MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_ :: Int
+_MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_ = 5
+_MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_ = 5
+
+-- | Returns either 'id' or 'blockQuote' depending on the current indentation
+getParaModifier :: Style -> ParaModifier
+getParaModifier Style{..} | Just props <- paraProperties styleProperties
+ , isBlockQuote (indentation props)
+ (margin_left props)
+ = blockQuote
+ | otherwise
+ = id
+ where
+ isBlockQuote mIndent mMargin
+ | LengthValueMM indent <- mIndent
+ , indent > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_
+ = True
+ | LengthValueMM margin <- mMargin
+ , margin > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_
+ = True
+ | LengthValueMM indent <- mIndent
+ , LengthValueMM margin <- mMargin
+ = indent + margin > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_MM_
+
+ | PercentValue indent <- mIndent
+ , indent > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_
+ = True
+ | PercentValue margin <- mMargin
+ , margin > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_
+ = True
+ | PercentValue indent <- mIndent
+ , PercentValue margin <- mMargin
+ = indent + margin > _MINIMUM_INDENTATION_FOR_BLOCKQUOTES_IN_PERCENT_
+
+ | otherwise
+ = False
+
+--
+constructPara :: OdtReaderSafe Blocks Blocks -> OdtReaderSafe Blocks Blocks
+constructPara reader = proc blocks -> do
+ fStyle <- readStyleByName -< blocks
+ case fStyle of
+ Left _ -> reader -< blocks
+ Right style -> do
+ let modifier = getParaModifier style
+ blocks' <- reader -< blocks
+ arr modifier -<< blocks'
+
+
+
+type ListConstructor = [Blocks] -> Blocks
+
+getListConstructor :: ListLevelStyle -> ListConstructor
+getListConstructor ListLevelStyle{..} =
+ case listLevelType of
+ LltBullet -> bulletList
+ LltImage -> bulletList
+ LltNumbered -> let listNumberStyle = toListNumberStyle listItemFormat
+ listNumberDelim = toListNumberDelim listItemPrefix
+ listItemSuffix
+ in orderedListWith (1, listNumberStyle, listNumberDelim)
+ where
+ toListNumberStyle LinfNone = DefaultStyle
+ toListNumberStyle LinfNumber = Decimal
+ toListNumberStyle LinfRomanLC = LowerRoman
+ toListNumberStyle LinfRomanUC = UpperRoman
+ toListNumberStyle LinfAlphaLC = LowerAlpha
+ toListNumberStyle LinfAlphaUC = UpperAlpha
+ toListNumberStyle (LinfString _) = Example
+
+ toListNumberDelim Nothing (Just ".") = Period
+ toListNumberDelim (Just "" ) (Just ".") = Period
+ toListNumberDelim Nothing (Just ")") = OneParen
+ toListNumberDelim (Just "" ) (Just ")") = OneParen
+ toListNumberDelim (Just "(") (Just ")") = TwoParens
+ toListNumberDelim _ _ = DefaultDelim
+
+
+-- | Determines which style to use for a list, which level to use of that
+-- style, and which type of list to create as a result of this information.
+-- Then prepares the state for eventual child lists and constructs the list from
+-- the results.
+-- Two main cases are handled: The list may provide its own style or it may
+-- rely on a parent list's style. I the former case the current style in the
+-- state must be switched before and after the call to the child converter
+-- while in the latter the child converter can be called directly.
+-- If anything goes wrong, a default ordered-list-constructor is used.
+constructList :: OdtReaderSafe x [Blocks] -> OdtReaderSafe x Blocks
+constructList reader = proc x -> do
+ modifyExtraState (shiftListLevel 1) -< ()
+ listLevel <- getCurrentListLevel -< ()
+ fStyleName <- findAttr NsText "style-name" -< ()
+ case fStyleName of
+ Right styleName -> do
+ fListStyle <- lookupListStyle -< styleName
+ case fListStyle of
+ Right listStyle -> do
+ fLLS <- arr (uncurry getListLevelStyle) -< (listLevel,listStyle)
+ case fLLS of
+ Just listLevelStyle -> do
+ oldListStyle <- switchCurrentListStyle -< Just listStyle
+ blocks <- constructListWith listLevelStyle -<< x
+ switchCurrentListStyle -< oldListStyle
+ returnA -< blocks
+ Nothing -> constructOrderedList -< x
+ Left _ -> constructOrderedList -< x
+ Left _ -> do
+ state <- getExtraState -< ()
+ mListStyle <- arr currentListStyle -< state
+ case mListStyle of
+ Just listStyle -> do
+ fLLS <- arr (uncurry getListLevelStyle) -< (listLevel,listStyle)
+ case fLLS of
+ Just listLevelStyle -> constructListWith listLevelStyle -<< x
+ Nothing -> constructOrderedList -< x
+ Nothing -> constructOrderedList -< x
+ where
+ constructOrderedList =
+ reader
+ >>> modifyExtraState (shiftListLevel (-1))
+ >>^ orderedList
+ constructListWith listLevelStyle =
+ reader
+ >>> getListConstructor listLevelStyle
+ ^>> modifyExtraState (shiftListLevel (-1))
+
+--------------------------------------------------------------------------------
+-- Readers
+--------------------------------------------------------------------------------
+
+type ElementMatcher result = (Namespace, ElementName, OdtReader result result)
+
+type InlineMatcher = ElementMatcher Inlines
+
+type BlockMatcher = ElementMatcher Blocks
+
+
+--
+matchingElement :: (Monoid e)
+ => Namespace -> ElementName
+ -> OdtReaderSafe e e
+ -> ElementMatcher e
+matchingElement ns name reader = (ns, name, asResultAccumulator reader)
+ where
+ asResultAccumulator :: (ArrowChoice a, Monoid m) => a m m -> a m (Fallible m)
+ asResultAccumulator a = liftAsSuccess $ keepingTheValue a >>§ (<>)
+
+--
+matchChildContent' :: (Monoid result)
+ => [ElementMatcher result]
+ -> OdtReaderSafe _x result
+matchChildContent' ls = returnV mempty >>> matchContent' ls
+
+--
+matchChildContent :: (Monoid result)
+ => [ElementMatcher result]
+ -> OdtReaderSafe (result, XML.Content) result
+ -> OdtReaderSafe _x result
+matchChildContent ls fallback = returnV mempty >>> matchContent ls fallback
+
+
+--------------------------------------------
+-- Matchers
+--------------------------------------------
+
+----------------------
+-- Basics
+----------------------
+
+--
+-- | Open Document allows several consecutive spaces if they are marked up
+read_plain_text :: OdtReaderSafe (Inlines, XML.Content) Inlines
+read_plain_text = fst ^&&& read_plain_text' >>§ recover
+ where
+ -- fallible version
+ read_plain_text' :: OdtReader (Inlines, XML.Content) Inlines
+ read_plain_text' = ( second ( arr extractText )
+ >>^ spreadChoice >>?! second text
+ )
+ >>?§ (<>)
+ --
+ extractText :: XML.Content -> Fallible String
+ extractText (XML.Text cData) = succeedWith (XML.cdData cData)
+ extractText _ = failEmpty
+
+
+-- specifically. I honor that, although the current implementation of '(<>)'
+-- for 'Inlines' in "Text.Pandoc.Builder" will collaps them agein.
+-- The rational is to be prepared for future modifications.
+read_spaces :: InlineMatcher
+read_spaces = matchingElement NsText "s" (
+ readAttrWithDefault NsText "c" 1 -- how many spaces?
+ >>^ fromList.(`replicate` Space)
+ )
+--
+read_line_break :: InlineMatcher
+read_line_break = matchingElement NsText "line-break"
+ $ returnV linebreak
+
+--
+read_span :: InlineMatcher
+read_span = matchingElement NsText "span"
+ $ withNewStyle
+ $ matchChildContent [ read_span
+ , read_spaces
+ , read_line_break
+ , read_link
+ , read_note
+ , read_citation
+ , read_bookmark
+ , read_bookmark_start
+ , read_reference_start
+ , read_bookmark_ref
+ , read_reference_ref
+ ] read_plain_text
+
+--
+read_paragraph :: BlockMatcher
+read_paragraph = matchingElement NsText "p"
+ $ constructPara
+ $ liftA para
+ $ withNewStyle
+ $ matchChildContent [ read_span
+ , read_spaces
+ , read_line_break
+ , read_link
+ , read_note
+ , read_citation
+ , read_bookmark
+ , read_bookmark_start
+ , read_reference_start
+ , read_bookmark_ref
+ , read_reference_ref
+ ] read_plain_text
+
+
+----------------------
+-- Headers
+----------------------
+
+--
+read_header :: BlockMatcher
+read_header = matchingElement NsText "h"
+ $ proc blocks -> do
+ level <- ( readAttrWithDefault NsText "outline-level" 1
+ ) -< blocks
+ children <- ( matchChildContent [ read_span
+ , read_spaces
+ , read_line_break
+ , read_link
+ , read_note
+ , read_citation
+ , read_bookmark
+ , read_bookmark_start
+ , read_reference_start
+ , read_bookmark_ref
+ , read_reference_ref
+ ] read_plain_text
+ ) -< blocks
+ anchor <- getHeaderAnchor -< children
+ let idAttr = (anchor, [], []) -- no classes, no key-value pairs
+ arr (uncurry3 headerWith) -< (idAttr, level, children)
+
+----------------------
+-- Lists
+----------------------
+
+--
+read_list :: BlockMatcher
+read_list = matchingElement NsText "list"
+-- $ withIncreasedListLevel
+ $ constructList
+-- $ liftA bulletList
+ $ matchChildContent' [ read_list_item
+ ]
+--
+read_list_item :: ElementMatcher [Blocks]
+read_list_item = matchingElement NsText "list-item"
+ $ liftA (compactify'.(:[]))
+ ( matchChildContent' [ read_paragraph
+ , read_header
+ , read_list
+ ]
+ )
+
+
+----------------------
+-- Links
+----------------------
+
+read_link :: InlineMatcher
+read_link = matchingElement NsText "a"
+ $ liftA3 link
+ ( findAttrWithDefault NsXLink "href" "" )
+ ( findAttrWithDefault NsOffice "title" "" )
+ ( matchChildContent [ read_span
+ , read_note
+ , read_citation
+ , read_bookmark
+ , read_bookmark_start
+ , read_reference_start
+ , read_bookmark_ref
+ , read_reference_ref
+ ] read_plain_text )
+
+
+-------------------------
+-- Footnotes
+-------------------------
+
+read_note :: InlineMatcher
+read_note = matchingElement NsText "note"
+ $ liftA note
+ $ matchChildContent' [ read_note_body ]
+
+read_note_body :: BlockMatcher
+read_note_body = matchingElement NsText "note-body"
+ $ matchChildContent' [ read_paragraph ]
+
+-------------------------
+-- Citations
+-------------------------
+
+read_citation :: InlineMatcher
+read_citation = matchingElement NsText "bibliography-mark"
+ $ liftA2 cite
+ ( liftA2 makeCitation
+ ( findAttrWithDefault NsText "identifier" "" )
+ ( readAttrWithDefault NsText "number" 0 )
+ )
+ ( matchChildContent [] read_plain_text )
+ where
+ makeCitation :: String -> Int -> [Citation]
+ makeCitation citeId num = [Citation citeId [] [] NormalCitation num 0]
+
+
+----------------------
+-- Tables
+----------------------
+
+--
+read_table :: BlockMatcher
+read_table = matchingElement NsTable "table"
+ $ liftA (simpleTable [])
+ $ matchChildContent' [ read_table_row
+ ]
+
+--
+read_table_row :: ElementMatcher [[Blocks]]
+read_table_row = matchingElement NsTable "table-row"
+ $ liftA (:[])
+ $ matchChildContent' [ read_table_cell
+ ]
+
+--
+read_table_cell :: ElementMatcher [Blocks]
+read_table_cell = matchingElement NsTable "table-cell"
+ $ liftA (compactify'.(:[]))
+ $ matchChildContent' [ read_paragraph
+ ]
+
+----------------------
+-- Internal links
+----------------------
+
+_ANCHOR_PREFIX_ :: String
+_ANCHOR_PREFIX_ = "anchor"
+
+--
+readAnchorAttr :: OdtReader _x Anchor
+readAnchorAttr = findAttr NsText "name"
+
+-- | Beware: may fail
+findAnchorName :: OdtReader AnchorPrefix Anchor
+findAnchorName = ( keepingTheValue readAnchorAttr
+ >>^ spreadChoice
+ ) >>?! getPrettyAnchor
+
+
+--
+maybeAddAnchorFrom :: OdtReader Inlines AnchorPrefix
+ -> OdtReaderSafe Inlines Inlines
+maybeAddAnchorFrom anchorReader =
+ keepingTheValue (anchorReader >>? findAnchorName >>?^ toAnchorElem)
+ >>>
+ proc (inlines, fAnchorElem) -> do
+ case fAnchorElem of
+ Right anchorElem ->
+ arr (anchorElem <>) -<< inlines
+ Left _ -> returnA -< inlines
+ where
+ toAnchorElem :: Anchor -> Inlines
+ toAnchorElem anchorID = spanWith (anchorID, [], []) mempty
+ -- no classes, no key-value pairs
+
+--
+read_bookmark :: InlineMatcher
+read_bookmark = matchingElement NsText "bookmark"
+ $ maybeAddAnchorFrom (liftAsSuccess $ returnV _ANCHOR_PREFIX_)
+
+--
+read_bookmark_start :: InlineMatcher
+read_bookmark_start = matchingElement NsText "bookmark-start"
+ $ maybeAddAnchorFrom (liftAsSuccess $ returnV _ANCHOR_PREFIX_)
+
+--
+read_reference_start :: InlineMatcher
+read_reference_start = matchingElement NsText "reference-mark-start"
+ $ maybeAddAnchorFrom readAnchorAttr
+
+-- | Beware: may fail
+findAnchorRef :: OdtReader _x Anchor
+findAnchorRef = ( findAttr NsText "ref-name"
+ >>?^ (_ANCHOR_PREFIX_,)
+ ) >>?! getPrettyAnchor
+
+
+--
+maybeInAnchorRef :: OdtReaderSafe Inlines Inlines
+maybeInAnchorRef = proc inlines -> do
+ fRef <- findAnchorRef -< ()
+ case fRef of
+ Right anchor ->
+ arr (toAnchorRef anchor) -<< inlines
+ Left _ -> returnA -< inlines
+ where
+ toAnchorRef :: Anchor -> Inlines -> Inlines
+ toAnchorRef anchor = link ('#':anchor) "" -- no title
+
+--
+read_bookmark_ref :: InlineMatcher
+read_bookmark_ref = matchingElement NsText "bookmark-ref"
+ $ maybeInAnchorRef
+ <<< matchChildContent [] read_plain_text
+
+--
+read_reference_ref :: InlineMatcher
+read_reference_ref = matchingElement NsText "reference-ref"
+ $ maybeInAnchorRef
+ <<< matchChildContent [] read_plain_text
+
+
+----------------------
+-- Entry point
+----------------------
+
+--read_plain_content :: OdtReaderSafe _x Inlines
+--read_plain_content = strContent >>^ text
+
+read_text :: OdtReaderSafe _x Pandoc
+read_text = matchChildContent' [ read_header
+ , read_paragraph
+ , read_list
+ , read_table
+ ]
+ >>^ doc
+
+read_body :: OdtReader _x Pandoc
+read_body = executeIn NsOffice "body"
+ $ executeIn NsOffice "text"
+ $ liftAsSuccess read_text
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-12 23:52:31 +0000