path: root/src/Text/Pandoc/Readers/Odt/ContentReader.hs

{-# 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