{-# LANGUAGE ViewPatterns      #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
 Module : Text.Pandoc.Readers.Docx.Parse
 Copyright : Copyright (C) 2014-2020 Jesse Rosenthal
                           2019 Nikolay Yakimov <root@livid.pp.ru>
 License : GNU GPL, version 2 or above

 Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
 Stability : alpha
 Portability : portable

Conversion of docx archive into Docx haskell type
-}

module Text.Pandoc.Readers.Docx.Parse ( Docx(..)
                                      , Document(..)
                                      , Body(..)
                                      , BodyPart(..)
                                      , TblLook(..)
                                      , Extent
                                      , ParPart(..)
                                      , Run(..)
                                      , RunElem(..)
                                      , Notes
                                      , Numbering
                                      , Relationship
                                      , Media
                                      , RunStyle(..)
                                      , VertAlign(..)
                                      , ParIndentation(..)
                                      , ParagraphStyle(..)
                                      , ParStyle
                                      , CharStyle(cStyleData)
                                      , Row(..)
                                      , TblHeader(..)
                                      , Cell(..)
                                      , VMerge(..)
                                      , TrackedChange(..)
                                      , ChangeType(..)
                                      , ChangeInfo(..)
                                      , FieldInfo(..)
                                      , Level(..)
                                      , ParaStyleName
                                      , CharStyleName
                                      , FromStyleName(..)
                                      , HasStyleName(..)
                                      , HasParentStyle(..)
                                      , archiveToDocx
                                      , archiveToDocxWithWarnings
                                      , getStyleNames
                                      , pHeading
                                      , pStyleIndentation
                                      , constructBogusParStyleData
                                      , leftBiasedMergeRunStyle
                                      , rowsToRowspans
                                      ) where
import Text.Pandoc.Readers.Docx.Parse.Styles
import Codec.Archive.Zip
import Control.Applicative ((<|>))
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Bits ((.|.))
import qualified Data.ByteString.Lazy as B
import Data.Char (chr, ord, readLitChar)
import Data.List
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Text (Text)
import Data.Maybe
import System.FilePath
import Text.Pandoc.Readers.Docx.Util
import Text.Pandoc.Readers.Docx.Fields
import Text.Pandoc.Shared (filteredFilesFromArchive, safeRead)
import qualified Text.Pandoc.UTF8 as UTF8
import Text.TeXMath (Exp)
import Text.TeXMath.Readers.OMML (readOMML)
import Text.TeXMath.Unicode.Fonts (Font (..), getUnicode, textToFont)
import Text.Pandoc.XML.Light
    ( filterChild,
      findElement,
      strContent,
      showElement,
      findAttr,
      filterChild,
      filterChildrenName,
      filterElementName,
      lookupAttrBy,
      parseXMLElement,
      elChildren,
      QName(QName, qName),
      Content(Elem),
      Element(..),
      findElements )

data ReaderEnv = ReaderEnv { ReaderEnv -> Notes
envNotes         :: Notes
                           , ReaderEnv -> Comments
envComments      :: Comments
                           , ReaderEnv -> Numbering
envNumbering     :: Numbering
                           , ReaderEnv -> [Relationship]
envRelationships :: [Relationship]
                           , ReaderEnv -> Media
envMedia         :: Media
                           , ReaderEnv -> Maybe Font
envFont          :: Maybe Font
                           , ReaderEnv -> CharStyleMap
envCharStyles    :: CharStyleMap
                           , ReaderEnv -> ParStyleMap
envParStyles     :: ParStyleMap
                           , ReaderEnv -> DocumentLocation
envLocation      :: DocumentLocation
                           , ReaderEnv -> [Char]
envDocXmlPath    :: FilePath
                           }
               deriving Int -> ReaderEnv -> ShowS
[ReaderEnv] -> ShowS
ReaderEnv -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ReaderEnv] -> ShowS
$cshowList :: [ReaderEnv] -> ShowS
show :: ReaderEnv -> [Char]
$cshow :: ReaderEnv -> [Char]
showsPrec :: Int -> ReaderEnv -> ShowS
$cshowsPrec :: Int -> ReaderEnv -> ShowS
Show

data ReaderState = ReaderState { ReaderState -> [Text]
stateWarnings :: [T.Text]
                               , ReaderState -> [FldCharState]
stateFldCharState :: [FldCharState]
                               }
                 deriving Int -> ReaderState -> ShowS
[ReaderState] -> ShowS
ReaderState -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ReaderState] -> ShowS
$cshowList :: [ReaderState] -> ShowS
show :: ReaderState -> [Char]
$cshow :: ReaderState -> [Char]
showsPrec :: Int -> ReaderState -> ShowS
$cshowsPrec :: Int -> ReaderState -> ShowS
Show

data FldCharState = FldCharOpen
                  | FldCharFieldInfo FieldInfo
                  | FldCharContent FieldInfo [ParPart]
                  deriving (Int -> FldCharState -> ShowS
[FldCharState] -> ShowS
FldCharState -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FldCharState] -> ShowS
$cshowList :: [FldCharState] -> ShowS
show :: FldCharState -> [Char]
$cshow :: FldCharState -> [Char]
showsPrec :: Int -> FldCharState -> ShowS
$cshowsPrec :: Int -> FldCharState -> ShowS
Show)

data DocxError = DocxError
               | WrongElem
               deriving Int -> DocxError -> ShowS
[DocxError] -> ShowS
DocxError -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [DocxError] -> ShowS
$cshowList :: [DocxError] -> ShowS
show :: DocxError -> [Char]
$cshow :: DocxError -> [Char]
showsPrec :: Int -> DocxError -> ShowS
$cshowsPrec :: Int -> DocxError -> ShowS
Show

type D = ExceptT DocxError (ReaderT ReaderEnv (State ReaderState))

runD :: D a -> ReaderEnv -> ReaderState -> (Either DocxError a, ReaderState)
runD :: forall a.
D a
-> ReaderEnv -> ReaderState -> (Either DocxError a, ReaderState)
runD D a
dx ReaderEnv
re ReaderState
rs = forall s a. State s a -> s -> (a, s)
runState (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT D a
dx) ReaderEnv
re) ReaderState
rs

maybeToD :: Maybe a -> D a
maybeToD :: forall a. Maybe a -> D a
maybeToD (Just a
a) = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
maybeToD Maybe a
Nothing  = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
DocxError

eitherToD :: Either a b -> D b
eitherToD :: forall a b. Either a b -> D b
eitherToD (Right b
b) = forall (m :: * -> *) a. Monad m => a -> m a
return b
b
eitherToD (Left a
_)  = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
DocxError

concatMapM        :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
concatMapM :: forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM a -> m [b]
f [a]
xs   =  forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m [b]
f [a]
xs)

-- This is similar to `mapMaybe`: it maps a function returning the D
-- monad over a list, and only keeps the non-erroring return values.
mapD :: (a -> D b) -> [a] -> D [b]
mapD :: forall a b. (a -> D b) -> [a] -> D [b]
mapD a -> D b
f [a]
xs =
  let handler :: a -> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) [b]
handler a
x = (a -> D b
f a
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\b
y-> forall (m :: * -> *) a. Monad m => a -> m a
return [b
y])) forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (\DocxError
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return [])
  in
   forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM a -> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) [b]
handler [a]
xs

unwrapElement :: NameSpaces -> Element -> [Element]
unwrapElement :: NameSpaces -> Element -> [Element]
unwrapElement NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"sdt" Element
element
  , Just Element
sdtContent <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"sdtContent" Element
element
  = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (NameSpaces -> Element -> [Element]
unwrapElement NameSpaces
ns) (Element -> [Element]
elChildren Element
sdtContent)
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"smartTag" Element
element
  = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (NameSpaces -> Element -> [Element]
unwrapElement NameSpaces
ns) (Element -> [Element]
elChildren Element
element)
  | Bool
otherwise
  = [Element
element{ elContent :: [Content]
elContent = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (NameSpaces -> Content -> [Content]
unwrapContent NameSpaces
ns) (Element -> [Content]
elContent Element
element) }]

unwrapContent :: NameSpaces -> Content -> [Content]
unwrapContent :: NameSpaces -> Content -> [Content]
unwrapContent NameSpaces
ns (Elem Element
element) = forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem forall a b. (a -> b) -> a -> b
$ NameSpaces -> Element -> [Element]
unwrapElement NameSpaces
ns Element
element
unwrapContent NameSpaces
_ Content
content = [Content
content]

walkDocument :: NameSpaces -> Element -> Element
walkDocument :: NameSpaces -> Element -> Element
walkDocument NameSpaces
ns Element
element =
  Element
element{ elContent :: [Content]
elContent = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (NameSpaces -> Content -> [Content]
unwrapContent NameSpaces
ns) (Element -> [Content]
elContent Element
element) }

newtype Docx = Docx Document
          deriving Int -> Docx -> ShowS
[Docx] -> ShowS
Docx -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Docx] -> ShowS
$cshowList :: [Docx] -> ShowS
show :: Docx -> [Char]
$cshow :: Docx -> [Char]
showsPrec :: Int -> Docx -> ShowS
$cshowsPrec :: Int -> Docx -> ShowS
Show

data Document = Document NameSpaces Body
          deriving Int -> Document -> ShowS
[Document] -> ShowS
Document -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Document] -> ShowS
$cshowList :: [Document] -> ShowS
show :: Document -> [Char]
$cshow :: Document -> [Char]
showsPrec :: Int -> Document -> ShowS
$cshowsPrec :: Int -> Document -> ShowS
Show

newtype Body = Body [BodyPart]
          deriving Int -> Body -> ShowS
[Body] -> ShowS
Body -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Body] -> ShowS
$cshowList :: [Body] -> ShowS
show :: Body -> [Char]
$cshow :: Body -> [Char]
showsPrec :: Int -> Body -> ShowS
$cshowsPrec :: Int -> Body -> ShowS
Show

type Media = [(FilePath, B.ByteString)]

type CharStyleMap = M.Map CharStyleId CharStyle

type ParStyleMap = M.Map ParaStyleId ParStyle

data Numbering = Numbering NameSpaces [Numb] [AbstractNumb]
                 deriving Int -> Numbering -> ShowS
[Numbering] -> ShowS
Numbering -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Numbering] -> ShowS
$cshowList :: [Numbering] -> ShowS
show :: Numbering -> [Char]
$cshow :: Numbering -> [Char]
showsPrec :: Int -> Numbering -> ShowS
$cshowsPrec :: Int -> Numbering -> ShowS
Show

data Numb = Numb T.Text T.Text [LevelOverride]
            deriving Int -> Numb -> ShowS
[Numb] -> ShowS
Numb -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Numb] -> ShowS
$cshowList :: [Numb] -> ShowS
show :: Numb -> [Char]
$cshow :: Numb -> [Char]
showsPrec :: Int -> Numb -> ShowS
$cshowsPrec :: Int -> Numb -> ShowS
Show

--                                 ilvl    startOverride   lvl
data LevelOverride = LevelOverride T.Text (Maybe Integer) (Maybe Level)
  deriving Int -> LevelOverride -> ShowS
[LevelOverride] -> ShowS
LevelOverride -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [LevelOverride] -> ShowS
$cshowList :: [LevelOverride] -> ShowS
show :: LevelOverride -> [Char]
$cshow :: LevelOverride -> [Char]
showsPrec :: Int -> LevelOverride -> ShowS
$cshowsPrec :: Int -> LevelOverride -> ShowS
Show

data AbstractNumb = AbstractNumb T.Text [Level]
                    deriving Int -> AbstractNumb -> ShowS
[AbstractNumb] -> ShowS
AbstractNumb -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [AbstractNumb] -> ShowS
$cshowList :: [AbstractNumb] -> ShowS
show :: AbstractNumb -> [Char]
$cshow :: AbstractNumb -> [Char]
showsPrec :: Int -> AbstractNumb -> ShowS
$cshowsPrec :: Int -> AbstractNumb -> ShowS
Show

--                 ilvl   format string  start
data Level = Level T.Text T.Text T.Text (Maybe Integer)
  deriving Int -> Level -> ShowS
[Level] -> ShowS
Level -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Level] -> ShowS
$cshowList :: [Level] -> ShowS
show :: Level -> [Char]
$cshow :: Level -> [Char]
showsPrec :: Int -> Level -> ShowS
$cshowsPrec :: Int -> Level -> ShowS
Show

data DocumentLocation = InDocument | InFootnote | InEndnote
                      deriving (DocumentLocation -> DocumentLocation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DocumentLocation -> DocumentLocation -> Bool
$c/= :: DocumentLocation -> DocumentLocation -> Bool
== :: DocumentLocation -> DocumentLocation -> Bool
$c== :: DocumentLocation -> DocumentLocation -> Bool
Eq,Int -> DocumentLocation -> ShowS
[DocumentLocation] -> ShowS
DocumentLocation -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [DocumentLocation] -> ShowS
$cshowList :: [DocumentLocation] -> ShowS
show :: DocumentLocation -> [Char]
$cshow :: DocumentLocation -> [Char]
showsPrec :: Int -> DocumentLocation -> ShowS
$cshowsPrec :: Int -> DocumentLocation -> ShowS
Show)

data Relationship = Relationship DocumentLocation RelId Target
                  deriving Int -> Relationship -> ShowS
[Relationship] -> ShowS
Relationship -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Relationship] -> ShowS
$cshowList :: [Relationship] -> ShowS
show :: Relationship -> [Char]
$cshow :: Relationship -> [Char]
showsPrec :: Int -> Relationship -> ShowS
$cshowsPrec :: Int -> Relationship -> ShowS
Show

data Notes = Notes NameSpaces
             (Maybe (M.Map T.Text Element))
             (Maybe (M.Map T.Text Element))
           deriving Int -> Notes -> ShowS
[Notes] -> ShowS
Notes -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Notes] -> ShowS
$cshowList :: [Notes] -> ShowS
show :: Notes -> [Char]
$cshow :: Notes -> [Char]
showsPrec :: Int -> Notes -> ShowS
$cshowsPrec :: Int -> Notes -> ShowS
Show

data Comments = Comments NameSpaces (M.Map T.Text Element)
              deriving Int -> Comments -> ShowS
[Comments] -> ShowS
Comments -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Comments] -> ShowS
$cshowList :: [Comments] -> ShowS
show :: Comments -> [Char]
$cshow :: Comments -> [Char]
showsPrec :: Int -> Comments -> ShowS
$cshowsPrec :: Int -> Comments -> ShowS
Show

data ChangeType = Insertion | Deletion
                deriving Int -> ChangeType -> ShowS
[ChangeType] -> ShowS
ChangeType -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ChangeType] -> ShowS
$cshowList :: [ChangeType] -> ShowS
show :: ChangeType -> [Char]
$cshow :: ChangeType -> [Char]
showsPrec :: Int -> ChangeType -> ShowS
$cshowsPrec :: Int -> ChangeType -> ShowS
Show

data ChangeInfo = ChangeInfo ChangeId Author (Maybe ChangeDate)
                deriving Int -> ChangeInfo -> ShowS
[ChangeInfo] -> ShowS
ChangeInfo -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ChangeInfo] -> ShowS
$cshowList :: [ChangeInfo] -> ShowS
show :: ChangeInfo -> [Char]
$cshow :: ChangeInfo -> [Char]
showsPrec :: Int -> ChangeInfo -> ShowS
$cshowsPrec :: Int -> ChangeInfo -> ShowS
Show

data TrackedChange = TrackedChange ChangeType ChangeInfo
                   deriving Int -> TrackedChange -> ShowS
[TrackedChange] -> ShowS
TrackedChange -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TrackedChange] -> ShowS
$cshowList :: [TrackedChange] -> ShowS
show :: TrackedChange -> [Char]
$cshow :: TrackedChange -> [Char]
showsPrec :: Int -> TrackedChange -> ShowS
$cshowsPrec :: Int -> TrackedChange -> ShowS
Show

data ParagraphStyle = ParagraphStyle { ParagraphStyle -> [ParStyle]
pStyle      :: [ParStyle]
                                     , ParagraphStyle -> Maybe ParIndentation
indentation :: Maybe ParIndentation
                                     , ParagraphStyle -> Bool
numbered    :: Bool
                                     , ParagraphStyle -> Bool
dropCap     :: Bool
                                     , ParagraphStyle -> Maybe TrackedChange
pChange     :: Maybe TrackedChange
                                     , ParagraphStyle -> Maybe Bool
pBidi       :: Maybe Bool
                                     }
                      deriving Int -> ParagraphStyle -> ShowS
[ParagraphStyle] -> ShowS
ParagraphStyle -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ParagraphStyle] -> ShowS
$cshowList :: [ParagraphStyle] -> ShowS
show :: ParagraphStyle -> [Char]
$cshow :: ParagraphStyle -> [Char]
showsPrec :: Int -> ParagraphStyle -> ShowS
$cshowsPrec :: Int -> ParagraphStyle -> ShowS
Show

defaultParagraphStyle :: ParagraphStyle
defaultParagraphStyle :: ParagraphStyle
defaultParagraphStyle = ParagraphStyle { pStyle :: [ParStyle]
pStyle = []
                                       , indentation :: Maybe ParIndentation
indentation = forall a. Maybe a
Nothing
                                       , numbered :: Bool
numbered    = Bool
False
                                       , dropCap :: Bool
dropCap     = Bool
False
                                       , pChange :: Maybe TrackedChange
pChange     = forall a. Maybe a
Nothing
                                       , pBidi :: Maybe Bool
pBidi       = forall a. a -> Maybe a
Just Bool
False
                                       }


data BodyPart = Paragraph ParagraphStyle [ParPart]
              | ListItem ParagraphStyle T.Text T.Text (Maybe Level) [ParPart]
              | Tbl T.Text TblGrid TblLook [Row]
              | TblCaption ParagraphStyle [ParPart]
              deriving Int -> BodyPart -> ShowS
[BodyPart] -> ShowS
BodyPart -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [BodyPart] -> ShowS
$cshowList :: [BodyPart] -> ShowS
show :: BodyPart -> [Char]
$cshow :: BodyPart -> [Char]
showsPrec :: Int -> BodyPart -> ShowS
$cshowsPrec :: Int -> BodyPart -> ShowS
Show

type TblGrid = [Integer]

newtype TblLook = TblLook {TblLook -> Bool
firstRowFormatting::Bool}
              deriving Int -> TblLook -> ShowS
[TblLook] -> ShowS
TblLook -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TblLook] -> ShowS
$cshowList :: [TblLook] -> ShowS
show :: TblLook -> [Char]
$cshow :: TblLook -> [Char]
showsPrec :: Int -> TblLook -> ShowS
$cshowsPrec :: Int -> TblLook -> ShowS
Show

defaultTblLook :: TblLook
defaultTblLook :: TblLook
defaultTblLook = TblLook{firstRowFormatting :: Bool
firstRowFormatting = Bool
False}

data Row = Row TblHeader [Cell] deriving Int -> Row -> ShowS
[Row] -> ShowS
Row -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Row] -> ShowS
$cshowList :: [Row] -> ShowS
show :: Row -> [Char]
$cshow :: Row -> [Char]
showsPrec :: Int -> Row -> ShowS
$cshowsPrec :: Int -> Row -> ShowS
Show

data TblHeader = HasTblHeader | NoTblHeader deriving (Int -> TblHeader -> ShowS
[TblHeader] -> ShowS
TblHeader -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TblHeader] -> ShowS
$cshowList :: [TblHeader] -> ShowS
show :: TblHeader -> [Char]
$cshow :: TblHeader -> [Char]
showsPrec :: Int -> TblHeader -> ShowS
$cshowsPrec :: Int -> TblHeader -> ShowS
Show, TblHeader -> TblHeader -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TblHeader -> TblHeader -> Bool
$c/= :: TblHeader -> TblHeader -> Bool
== :: TblHeader -> TblHeader -> Bool
$c== :: TblHeader -> TblHeader -> Bool
Eq)

data Cell = Cell GridSpan VMerge [BodyPart]
            deriving Int -> Cell -> ShowS
[Cell] -> ShowS
Cell -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Cell] -> ShowS
$cshowList :: [Cell] -> ShowS
show :: Cell -> [Char]
$cshow :: Cell -> [Char]
showsPrec :: Int -> Cell -> ShowS
$cshowsPrec :: Int -> Cell -> ShowS
Show

type GridSpan = Integer

data VMerge = Continue
            -- ^ This cell should be merged with the one above it
            | Restart
            -- ^ This cell should not be merged with the one above it
            deriving (Int -> VMerge -> ShowS
[VMerge] -> ShowS
VMerge -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [VMerge] -> ShowS
$cshowList :: [VMerge] -> ShowS
show :: VMerge -> [Char]
$cshow :: VMerge -> [Char]
showsPrec :: Int -> VMerge -> ShowS
$cshowsPrec :: Int -> VMerge -> ShowS
Show, VMerge -> VMerge -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VMerge -> VMerge -> Bool
$c/= :: VMerge -> VMerge -> Bool
== :: VMerge -> VMerge -> Bool
$c== :: VMerge -> VMerge -> Bool
Eq)

rowsToRowspans :: [Row] -> [[(Int, Cell)]]
rowsToRowspans :: [Row] -> [[(Int, Cell)]]
rowsToRowspans [Row]
rows = let
  removeMergedCells :: [[(a, Cell)]] -> [[(a, Cell)]]
removeMergedCells = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
_, Cell GridSpan
_ VMerge
vmerge [BodyPart]
_) -> VMerge
vmerge forall a. Eq a => a -> a -> Bool
== VMerge
Restart))
  in forall {a}. [[(a, Cell)]] -> [[(a, Cell)]]
removeMergedCells (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Row -> [[(Int, Cell)]] -> [[(Int, Cell)]]
f [] [Row]
rows)
  where
    f :: Row -> [[(Int, Cell)]] -> [[(Int, Cell)]]
    f :: Row -> [[(Int, Cell)]] -> [[(Int, Cell)]]
f (Row TblHeader
_ [Cell]
cells) [[(Int, Cell)]]
acc = let
      spans :: [(Int, Cell)]
spans = [Cell] -> Maybe GridSpan -> Maybe [(Int, Cell)] -> [(Int, Cell)]
g [Cell]
cells forall a. Maybe a
Nothing (forall a. [a] -> Maybe a
listToMaybe [[(Int, Cell)]]
acc)
      in [(Int, Cell)]
spans forall a. a -> [a] -> [a]
: [[(Int, Cell)]]
acc

    g :: [Cell] -- the current row
      -> Maybe Integer -- Number of columns left below
      -> Maybe [(Int, Cell)] -- (rowspan so far, cell) for the row below this one
      -> [(Int, Cell)] -- (rowspan so far, cell) for this row
    g :: [Cell] -> Maybe GridSpan -> Maybe [(Int, Cell)] -> [(Int, Cell)]
g [Cell]
cells Maybe GridSpan
_ Maybe [(Int, Cell)]
Nothing = forall a b. (a -> b) -> [a] -> [b]
map (Int
1,) [Cell]
cells
    g [Cell]
cells Maybe GridSpan
columnsLeftBelow (Just [(Int, Cell)]
rowBelow) =
        case [Cell]
cells of
          [] -> []
          thisCell :: Cell
thisCell@(Cell GridSpan
thisGridSpan VMerge
_ [BodyPart]
_) : [Cell]
restOfRow -> case [(Int, Cell)]
rowBelow of
            [] -> forall a b. (a -> b) -> [a] -> [b]
map (Int
1,) [Cell]
cells
            (Int
spanSoFarBelow, Cell GridSpan
gridSpanBelow VMerge
vmerge [BodyPart]
_) : [(Int, Cell)]
_ ->
              let spanSoFar :: Int
spanSoFar = case VMerge
vmerge of
                    VMerge
Restart -> Int
1
                    VMerge
Continue -> Int
1 forall a. Num a => a -> a -> a
+ Int
spanSoFarBelow
                  columnsToDrop :: GridSpan
columnsToDrop = GridSpan
thisGridSpan forall a. Num a => a -> a -> a
+ (GridSpan
gridSpanBelow forall a. Num a => a -> a -> a
- forall a. a -> Maybe a -> a
fromMaybe GridSpan
gridSpanBelow Maybe GridSpan
columnsLeftBelow)
                  (GridSpan
newColumnsLeftBelow, [(Int, Cell)]
restOfRowBelow) = forall a. GridSpan -> [(a, Cell)] -> (GridSpan, [(a, Cell)])
dropColumns GridSpan
columnsToDrop [(Int, Cell)]
rowBelow
              in (Int
spanSoFar, Cell
thisCell) forall a. a -> [a] -> [a]
: [Cell] -> Maybe GridSpan -> Maybe [(Int, Cell)] -> [(Int, Cell)]
g [Cell]
restOfRow (forall a. a -> Maybe a
Just GridSpan
newColumnsLeftBelow) (forall a. a -> Maybe a
Just [(Int, Cell)]
restOfRowBelow)

    dropColumns :: Integer -> [(a, Cell)] -> (Integer, [(a, Cell)])
    dropColumns :: forall a. GridSpan -> [(a, Cell)] -> (GridSpan, [(a, Cell)])
dropColumns GridSpan
n [] = (GridSpan
n, [])
    dropColumns GridSpan
n cells :: [(a, Cell)]
cells@((a
_, Cell GridSpan
gridSpan VMerge
_ [BodyPart]
_) : [(a, Cell)]
otherCells) =
      if GridSpan
n forall a. Ord a => a -> a -> Bool
< GridSpan
gridSpan
      then (GridSpan
gridSpan forall a. Num a => a -> a -> a
- GridSpan
n, [(a, Cell)]
cells)
      else forall a. GridSpan -> [(a, Cell)] -> (GridSpan, [(a, Cell)])
dropColumns (GridSpan
n forall a. Num a => a -> a -> a
- GridSpan
gridSpan) [(a, Cell)]
otherCells

leftBiasedMergeRunStyle :: RunStyle -> RunStyle -> RunStyle
leftBiasedMergeRunStyle :: RunStyle -> RunStyle -> RunStyle
leftBiasedMergeRunStyle RunStyle
a RunStyle
b = RunStyle
    { isBold :: Maybe Bool
isBold = RunStyle -> Maybe Bool
isBold RunStyle
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RunStyle -> Maybe Bool
isBold RunStyle
b
    , isBoldCTL :: Maybe Bool
isBoldCTL = RunStyle -> Maybe Bool
isBoldCTL RunStyle
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RunStyle -> Maybe Bool
isBoldCTL RunStyle
b
    , isItalic :: Maybe Bool
isItalic = RunStyle -> Maybe Bool
isItalic RunStyle
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RunStyle -> Maybe Bool
isItalic RunStyle
b
    , isItalicCTL :: Maybe Bool
isItalicCTL = RunStyle -> Maybe Bool
isItalicCTL RunStyle
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RunStyle -> Maybe Bool
isItalicCTL RunStyle
b
    , isSmallCaps :: Maybe Bool
isSmallCaps = RunStyle -> Maybe Bool
isSmallCaps RunStyle
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RunStyle -> Maybe Bool
isSmallCaps RunStyle
b
    , isStrike :: Maybe Bool
isStrike = RunStyle -> Maybe Bool
isStrike RunStyle
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RunStyle -> Maybe Bool
isStrike RunStyle
b
    , isRTL :: Maybe Bool
isRTL = RunStyle -> Maybe Bool
isRTL RunStyle
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RunStyle -> Maybe Bool
isRTL RunStyle
b
    , isForceCTL :: Maybe Bool
isForceCTL = RunStyle -> Maybe Bool
isForceCTL RunStyle
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RunStyle -> Maybe Bool
isForceCTL RunStyle
b
    , rHighlight :: Maybe Text
rHighlight = RunStyle -> Maybe Text
rHighlight RunStyle
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RunStyle -> Maybe Text
rHighlight RunStyle
b
    , rVertAlign :: Maybe VertAlign
rVertAlign = RunStyle -> Maybe VertAlign
rVertAlign RunStyle
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RunStyle -> Maybe VertAlign
rVertAlign RunStyle
b
    , rUnderline :: Maybe Text
rUnderline = RunStyle -> Maybe Text
rUnderline RunStyle
a forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RunStyle -> Maybe Text
rUnderline RunStyle
b
    , rParentStyle :: Maybe CharStyle
rParentStyle = RunStyle -> Maybe CharStyle
rParentStyle RunStyle
a
    }

-- (width, height) in EMUs
type Extent = Maybe (Double, Double)

data ParPart = PlainRun Run
             | ChangedRuns TrackedChange [Run]
             | CommentStart CommentId Author (Maybe CommentDate) [BodyPart]
             | CommentEnd CommentId
             | BookMark BookMarkId Anchor
             | InternalHyperLink Anchor [ParPart]
             | ExternalHyperLink URL [ParPart]
             | Drawing FilePath T.Text T.Text B.ByteString Extent -- title, alt
             | Chart                                              -- placeholder for now
             | Diagram                                            -- placeholder for now
             | PlainOMath [Exp]
             | OMathPara [Exp]
             | Field FieldInfo [ParPart]
             deriving Int -> ParPart -> ShowS
[ParPart] -> ShowS
ParPart -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ParPart] -> ShowS
$cshowList :: [ParPart] -> ShowS
show :: ParPart -> [Char]
$cshow :: ParPart -> [Char]
showsPrec :: Int -> ParPart -> ShowS
$cshowsPrec :: Int -> ParPart -> ShowS
Show

data Run = Run RunStyle [RunElem]
         | Footnote [BodyPart]
         | Endnote [BodyPart]
         | InlineDrawing FilePath T.Text T.Text B.ByteString Extent -- title, alt
         | InlineChart          -- placeholder
         | InlineDiagram        -- placeholder
           deriving Int -> Run -> ShowS
[Run] -> ShowS
Run -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Run] -> ShowS
$cshowList :: [Run] -> ShowS
show :: Run -> [Char]
$cshow :: Run -> [Char]
showsPrec :: Int -> Run -> ShowS
$cshowsPrec :: Int -> Run -> ShowS
Show

data RunElem = TextRun T.Text | LnBrk | Tab | SoftHyphen | NoBreakHyphen
             deriving Int -> RunElem -> ShowS
[RunElem] -> ShowS
RunElem -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RunElem] -> ShowS
$cshowList :: [RunElem] -> ShowS
show :: RunElem -> [Char]
$cshow :: RunElem -> [Char]
showsPrec :: Int -> RunElem -> ShowS
$cshowsPrec :: Int -> RunElem -> ShowS
Show

type Target = T.Text
type Anchor = T.Text
type URL = T.Text
type BookMarkId = T.Text
type RelId = T.Text
type ChangeId = T.Text
type CommentId = T.Text
type Author = T.Text
type ChangeDate = T.Text
type CommentDate = T.Text

archiveToDocx :: Archive -> Either DocxError Docx
archiveToDocx :: Archive -> Either DocxError Docx
archiveToDocx Archive
archive = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Archive -> Either DocxError (Docx, [Text])
archiveToDocxWithWarnings Archive
archive

archiveToDocxWithWarnings :: Archive -> Either DocxError (Docx, [T.Text])
archiveToDocxWithWarnings :: Archive -> Either DocxError (Docx, [Text])
archiveToDocxWithWarnings Archive
archive = do
  [Char]
docXmlPath <- case Archive -> Maybe [Char]
getDocumentXmlPath Archive
archive of
    Just [Char]
fp -> forall a b. b -> Either a b
Right [Char]
fp
    Maybe [Char]
Nothing -> forall a b. a -> Either a b
Left DocxError
DocxError
  let notes :: Notes
notes     = Archive -> Notes
archiveToNotes Archive
archive
      comments :: Comments
comments  = Archive -> Comments
archiveToComments Archive
archive
      numbering :: Numbering
numbering = Archive -> Numbering
archiveToNumbering Archive
archive
      rels :: [Relationship]
rels      = Archive -> [Char] -> [Relationship]
archiveToRelationships Archive
archive [Char]
docXmlPath
      media :: Media
media     = Archive -> ([Char] -> Bool) -> Media
filteredFilesFromArchive Archive
archive [Char] -> Bool
filePathIsMedia
      (CharStyleMap
styles, ParStyleMap
parstyles) = Archive -> (CharStyleMap, ParStyleMap)
archiveToStyles Archive
archive
      rEnv :: ReaderEnv
rEnv = ReaderEnv { envNotes :: Notes
envNotes = Notes
notes
                       , envComments :: Comments
envComments = Comments
comments
                       , envNumbering :: Numbering
envNumbering = Numbering
numbering
                       , envRelationships :: [Relationship]
envRelationships = [Relationship]
rels
                       , envMedia :: Media
envMedia = Media
media
                       , envFont :: Maybe Font
envFont = forall a. Maybe a
Nothing
                       , envCharStyles :: CharStyleMap
envCharStyles = CharStyleMap
styles
                       , envParStyles :: ParStyleMap
envParStyles = ParStyleMap
parstyles
                       , envLocation :: DocumentLocation
envLocation = DocumentLocation
InDocument
                       , envDocXmlPath :: [Char]
envDocXmlPath = [Char]
docXmlPath
                       }
      rState :: ReaderState
rState = ReaderState { stateWarnings :: [Text]
stateWarnings = []
                           , stateFldCharState :: [FldCharState]
stateFldCharState = []
                           }
      (Either DocxError Document
eitherDoc, ReaderState
st) = forall a.
D a
-> ReaderEnv -> ReaderState -> (Either DocxError a, ReaderState)
runD (Archive -> D Document
archiveToDocument Archive
archive) ReaderEnv
rEnv ReaderState
rState
  case Either DocxError Document
eitherDoc of
    Right Document
doc -> forall a b. b -> Either a b
Right (Document -> Docx
Docx Document
doc, ReaderState -> [Text]
stateWarnings ReaderState
st)
    Left DocxError
e    -> forall a b. a -> Either a b
Left DocxError
e

parseXMLFromEntry :: Entry -> Maybe Element
parseXMLFromEntry :: Entry -> Maybe Element
parseXMLFromEntry Entry
entry =
  case Text -> Either Text Element
parseXMLElement (ByteString -> Text
UTF8.toTextLazy (Entry -> ByteString
fromEntry Entry
entry)) of
    Left Text
_   -> forall a. Maybe a
Nothing
    Right Element
el -> forall a. a -> Maybe a
Just Element
el

getDocumentXmlPath :: Archive -> Maybe FilePath
getDocumentXmlPath :: Archive -> Maybe [Char]
getDocumentXmlPath Archive
zf = do
  Entry
entry <- [Char] -> Archive -> Maybe Entry
findEntryByPath [Char]
"_rels/.rels" Archive
zf
  Element
relsElem <- Entry -> Maybe Element
parseXMLFromEntry Entry
entry
  let rels :: [Element]
rels = (QName -> Bool) -> Element -> [Element]
filterChildrenName (\QName
n -> QName -> Text
qName QName
n forall a. Eq a => a -> a -> Bool
== Text
"Relationship") Element
relsElem
  Element
rel <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Element
e -> QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"Type" forall a. Maybe a
Nothing forall a. Maybe a
Nothing) Element
e forall a. Eq a => a -> a -> Bool
==
                       forall a. a -> Maybe a
Just Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument")
         [Element]
rels
  Text
fp <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"Target" forall a. Maybe a
Nothing forall a. Maybe a
Nothing) Element
rel
  -- sometimes there will be a leading slash, which windows seems to
  -- have trouble with.
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Text -> [Char]
T.unpack Text
fp of
    Char
'/' : [Char]
fp' -> [Char]
fp'
    [Char]
fp'       -> [Char]
fp'

archiveToDocument :: Archive -> D Document
archiveToDocument :: Archive -> D Document
archiveToDocument Archive
zf = do
  [Char]
docPath <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> [Char]
envDocXmlPath
  Entry
entry <- forall a. Maybe a -> D a
maybeToD forall a b. (a -> b) -> a -> b
$ [Char] -> Archive -> Maybe Entry
findEntryByPath [Char]
docPath Archive
zf
  Element
docElem <- forall a. Maybe a -> D a
maybeToD forall a b. (a -> b) -> a -> b
$ Entry -> Maybe Element
parseXMLFromEntry Entry
entry
  let namespaces :: NameSpaces
namespaces = Element -> NameSpaces
elemToNameSpaces Element
docElem
  Element
bodyElem <- forall a. Maybe a -> D a
maybeToD forall a b. (a -> b) -> a -> b
$ NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
namespaces Text
"w" Text
"body" Element
docElem
  let bodyElem' :: Element
bodyElem' = NameSpaces -> Element -> Element
walkDocument NameSpaces
namespaces Element
bodyElem
  Body
body <- NameSpaces -> Element -> D Body
elemToBody NameSpaces
namespaces Element
bodyElem'
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ NameSpaces -> Body -> Document
Document NameSpaces
namespaces Body
body

elemToBody :: NameSpaces -> Element -> D Body
elemToBody :: NameSpaces -> Element -> D Body
elemToBody NameSpaces
ns Element
element | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"body" Element
element =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [BodyPart] -> Body
Body (forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D BodyPart
elemToBodyPart NameSpaces
ns) (Element -> [Element]
elChildren Element
element))
elemToBody NameSpaces
_ Element
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem

archiveToStyles :: Archive -> (CharStyleMap, ParStyleMap)
archiveToStyles :: Archive -> (CharStyleMap, ParStyleMap)
archiveToStyles = forall k1 k2 a1 a2.
(Ord k1, Ord k2, ElemToStyle a1, ElemToStyle a2) =>
(a1 -> k1) -> (a2 -> k2) -> Archive -> (Map k1 a1, Map k2 a2)
archiveToStyles' forall a. HasStyleId a => a -> StyleId a
getStyleId forall a. HasStyleId a => a -> StyleId a
getStyleId

class HasParentStyle a where
  getParentStyle :: a -> Maybe a

instance HasParentStyle CharStyle where
  getParentStyle :: CharStyle -> Maybe CharStyle
getParentStyle = RunStyle -> Maybe CharStyle
rParentStyle forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharStyle -> RunStyle
cStyleData

instance HasParentStyle ParStyle where
  getParentStyle :: ParStyle -> Maybe ParStyle
getParentStyle = ParStyle -> Maybe ParStyle
psParentStyle

getStyleNames :: (Functor t, HasStyleName a) => t a -> t (StyleName a)
getStyleNames :: forall (t :: * -> *) a.
(Functor t, HasStyleName a) =>
t a -> t (StyleName a)
getStyleNames = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. HasStyleName a => a -> StyleName a
getStyleName

constructBogusParStyleData :: ParaStyleName -> ParStyle
constructBogusParStyleData :: ParaStyleName -> ParStyle
constructBogusParStyleData ParaStyleName
stName = ParStyle
  { headingLev :: Maybe (ParaStyleName, Int)
headingLev = forall a. Maybe a
Nothing
  , indent :: Maybe ParIndentation
indent = forall a. Maybe a
Nothing
  , numInfo :: Maybe (Text, Text)
numInfo = forall a. Maybe a
Nothing
  , psParentStyle :: Maybe ParStyle
psParentStyle = forall a. Maybe a
Nothing
  , pStyleName :: ParaStyleName
pStyleName = ParaStyleName
stName
  , pStyleId :: ParaStyleId
pStyleId = Text -> ParaStyleId
ParaStyleId forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.filter (forall a. Eq a => a -> a -> Bool
/=Char
' ') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromStyleName a => a -> Text
fromStyleName forall a b. (a -> b) -> a -> b
$ ParaStyleName
stName
  }

archiveToNotes :: Archive -> Notes
archiveToNotes :: Archive -> Notes
archiveToNotes Archive
zf =
  let fnElem :: Maybe Element
fnElem = [Char] -> Archive -> Maybe Entry
findEntryByPath [Char]
"word/footnotes.xml" Archive
zf
               forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Entry -> Maybe Element
parseXMLFromEntry
      enElem :: Maybe Element
enElem = [Char] -> Archive -> Maybe Entry
findEntryByPath [Char]
"word/endnotes.xml" Archive
zf
               forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Entry -> Maybe Element
parseXMLFromEntry
      fn_namespaces :: NameSpaces
fn_namespaces = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty Element -> NameSpaces
elemToNameSpaces Maybe Element
fnElem
      en_namespaces :: NameSpaces
en_namespaces = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty Element -> NameSpaces
elemToNameSpaces Maybe Element
enElem
      ns :: NameSpaces
ns = forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union NameSpaces
fn_namespaces NameSpaces
en_namespaces
      fn :: Maybe (Map Text Element)
fn = Maybe Element
fnElem forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Element -> Maybe (Map Text Element)
elemToNotes NameSpaces
ns Text
"footnote" forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpaces -> Element -> Element
walkDocument NameSpaces
ns
      en :: Maybe (Map Text Element)
en = Maybe Element
enElem forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Element -> Maybe (Map Text Element)
elemToNotes NameSpaces
ns Text
"endnote" forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpaces -> Element -> Element
walkDocument NameSpaces
ns
  in
   NameSpaces
-> Maybe (Map Text Element) -> Maybe (Map Text Element) -> Notes
Notes NameSpaces
ns Maybe (Map Text Element)
fn Maybe (Map Text Element)
en

archiveToComments :: Archive -> Comments
archiveToComments :: Archive -> Comments
archiveToComments Archive
zf =
  let cmtsElem :: Maybe Element
cmtsElem = [Char] -> Archive -> Maybe Entry
findEntryByPath [Char]
"word/comments.xml" Archive
zf
               forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Entry -> Maybe Element
parseXMLFromEntry
      cmts_namespaces :: NameSpaces
cmts_namespaces = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty Element -> NameSpaces
elemToNameSpaces Maybe Element
cmtsElem
      cmts :: Maybe (Map Text Element)
cmts = NameSpaces -> Element -> Map Text Element
elemToComments NameSpaces
cmts_namespaces forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpaces -> Element -> Element
walkDocument NameSpaces
cmts_namespaces forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
               Maybe Element
cmtsElem
  in
    case Maybe (Map Text Element)
cmts of
      Just Map Text Element
c  -> NameSpaces -> Map Text Element -> Comments
Comments NameSpaces
cmts_namespaces Map Text Element
c
      Maybe (Map Text Element)
Nothing -> NameSpaces -> Map Text Element -> Comments
Comments NameSpaces
cmts_namespaces forall k a. Map k a
M.empty

filePathToRelType :: FilePath -> FilePath -> Maybe DocumentLocation
filePathToRelType :: [Char] -> [Char] -> Maybe DocumentLocation
filePathToRelType [Char]
"word/_rels/footnotes.xml.rels" [Char]
_ = forall a. a -> Maybe a
Just DocumentLocation
InFootnote
filePathToRelType [Char]
"word/_rels/endnotes.xml.rels" [Char]
_ = forall a. a -> Maybe a
Just DocumentLocation
InEndnote
-- -- to see if it's a documentPath, we have to check against the dynamic
-- -- docPath specified in "_rels/.rels"
filePathToRelType [Char]
path [Char]
docXmlPath =
  if [Char]
path forall a. Eq a => a -> a -> Bool
== [Char]
"word/_rels/" forall a. [a] -> [a] -> [a]
++ ShowS
takeFileName [Char]
docXmlPath forall a. [a] -> [a] -> [a]
++ [Char]
".rels"
  then forall a. a -> Maybe a
Just DocumentLocation
InDocument
  else forall a. Maybe a
Nothing

relElemToRelationship :: FilePath -> DocumentLocation -> Element
                      -> Maybe Relationship
relElemToRelationship :: [Char] -> DocumentLocation -> Element -> Maybe Relationship
relElemToRelationship [Char]
fp DocumentLocation
relType Element
element | QName -> Text
qName (Element -> QName
elName Element
element) forall a. Eq a => a -> a -> Bool
== Text
"Relationship" =
  do
    Text
relId <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"Id" forall a. Maybe a
Nothing forall a. Maybe a
Nothing) Element
element
    Text
target <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"Target" forall a. Maybe a
Nothing forall a. Maybe a
Nothing) Element
element
    -- target may be relative (media/image1.jpeg) or absolute
    -- (/word/media/image1.jpeg); we need to relativize it (see #7374)
    let frontOfFp :: Text
frontOfFp = [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'_') [Char]
fp
    let target' :: Text
target' = forall a. a -> Maybe a -> a
fromMaybe Text
target forall a b. (a -> b) -> a -> b
$
           Text -> Text -> Maybe Text
T.stripPrefix Text
frontOfFp forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'/') Text
target
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DocumentLocation -> Text -> Text -> Relationship
Relationship DocumentLocation
relType Text
relId Text
target'
relElemToRelationship [Char]
_ DocumentLocation
_ Element
_ = forall a. Maybe a
Nothing

filePathToRelationships :: Archive -> FilePath -> FilePath ->  [Relationship]
filePathToRelationships :: Archive -> [Char] -> [Char] -> [Relationship]
filePathToRelationships Archive
ar [Char]
docXmlPath [Char]
fp
  | Just DocumentLocation
relType <- [Char] -> [Char] -> Maybe DocumentLocation
filePathToRelType [Char]
fp [Char]
docXmlPath
  , Just Entry
entry <- [Char] -> Archive -> Maybe Entry
findEntryByPath [Char]
fp Archive
ar
  , Just Element
relElems <- Entry -> Maybe Element
parseXMLFromEntry Entry
entry =
  forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Char] -> DocumentLocation -> Element -> Maybe Relationship
relElemToRelationship [Char]
fp DocumentLocation
relType) forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
relElems
filePathToRelationships Archive
_ [Char]
_ [Char]
_ = []

archiveToRelationships :: Archive -> FilePath -> [Relationship]
archiveToRelationships :: Archive -> [Char] -> [Relationship]
archiveToRelationships Archive
archive [Char]
docXmlPath =
  forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Archive -> [Char] -> [Char] -> [Relationship]
filePathToRelationships Archive
archive [Char]
docXmlPath) forall a b. (a -> b) -> a -> b
$ Archive -> [[Char]]
filesInArchive Archive
archive

filePathIsMedia :: FilePath -> Bool
filePathIsMedia :: [Char] -> Bool
filePathIsMedia [Char]
fp =
  [Char]
"media" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char] -> [[Char]]
splitDirectories (ShowS
takeDirectory [Char]
fp)

lookupLevel :: T.Text -> T.Text -> Numbering -> Maybe Level
lookupLevel :: Text -> Text -> Numbering -> Maybe Level
lookupLevel Text
numId Text
ilvl (Numbering NameSpaces
_ [Numb]
numbs [AbstractNumb]
absNumbs) = do
  (Text
absNumId, [LevelOverride]
ovrrides) <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
numId forall a b. (a -> b) -> a -> b
$
                          forall a b. (a -> b) -> [a] -> [b]
map (\(Numb Text
nid Text
absnumid [LevelOverride]
ovrRides) -> (Text
nid, (Text
absnumid, [LevelOverride]
ovrRides))) [Numb]
numbs
  [Level]
lvls <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
absNumId forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map (\(AbstractNumb Text
aid [Level]
ls) -> (Text
aid, [Level]
ls)) [AbstractNumb]
absNumbs
  -- this can be a maybe, so we do a let
  let lvlOverride :: Maybe LevelOverride
lvlOverride = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
ilvl forall a b. (a -> b) -> a -> b
$
                    forall a b. (a -> b) -> [a] -> [b]
map (\lo :: LevelOverride
lo@(LevelOverride Text
ilvl' Maybe GridSpan
_ Maybe Level
_) -> (Text
ilvl', LevelOverride
lo)) [LevelOverride]
ovrrides
  case Maybe LevelOverride
lvlOverride of
    Just (LevelOverride Text
_ Maybe GridSpan
_ (Just Level
lvl')) -> forall a. a -> Maybe a
Just Level
lvl'
    Just (LevelOverride Text
_ (Just GridSpan
strt) Maybe Level
_) ->
      forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
ilvl forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Level Text
i Text
fmt Text
s Maybe GridSpan
_) -> (Text
i, Text -> Text -> Text -> Maybe GridSpan -> Level
Level Text
i Text
fmt Text
s (forall a. a -> Maybe a
Just GridSpan
strt))) [Level]
lvls
    Maybe LevelOverride
_ ->
      forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
ilvl forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\l :: Level
l@(Level Text
i Text
_ Text
_ Maybe GridSpan
_) -> (Text
i, Level
l)) [Level]
lvls

loElemToLevelOverride :: NameSpaces -> Element -> Maybe LevelOverride
loElemToLevelOverride :: NameSpaces -> Element -> Maybe LevelOverride
loElemToLevelOverride NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"lvlOverride" Element
element = do
      Text
ilvl <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"ilvl" Element
element
      let startOverride :: Maybe GridSpan
startOverride = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"startOverride" Element
element
                          forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"val"
                          forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe GridSpan
stringToInteger
          lvl :: Maybe Level
lvl = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"lvl" Element
element
                forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Element -> Maybe Level
levelElemToLevel NameSpaces
ns
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Maybe GridSpan -> Maybe Level -> LevelOverride
LevelOverride Text
ilvl Maybe GridSpan
startOverride Maybe Level
lvl
loElemToLevelOverride NameSpaces
_ Element
_ = forall a. Maybe a
Nothing

numElemToNum :: NameSpaces -> Element -> Maybe Numb
numElemToNum :: NameSpaces -> Element -> Maybe Numb
numElemToNum NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"num" Element
element = do
      Text
numId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"numId" Element
element
      Text
absNumId <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"abstractNumId" Element
element
                  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"val"
      let lvlOverrides :: [LevelOverride]
lvlOverrides = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                         (NameSpaces -> Element -> Maybe LevelOverride
loElemToLevelOverride NameSpaces
ns)
                         (NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns Text
"w" Text
"lvlOverride" Element
element)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Text -> [LevelOverride] -> Numb
Numb Text
numId Text
absNumId [LevelOverride]
lvlOverrides
numElemToNum NameSpaces
_ Element
_ = forall a. Maybe a
Nothing

absNumElemToAbsNum :: NameSpaces -> Element -> Maybe AbstractNumb
absNumElemToAbsNum :: NameSpaces -> Element -> Maybe AbstractNumb
absNumElemToAbsNum NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"abstractNum" Element
element = do
      Text
absNumId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"abstractNumId" Element
element
      let levelElems :: [Element]
levelElems = NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns Text
"w" Text
"lvl" Element
element
          levels :: [Level]
levels = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NameSpaces -> Element -> Maybe Level
levelElemToLevel NameSpaces
ns) [Element]
levelElems
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> [Level] -> AbstractNumb
AbstractNumb Text
absNumId [Level]
levels
absNumElemToAbsNum NameSpaces
_ Element
_ = forall a. Maybe a
Nothing

levelElemToLevel :: NameSpaces -> Element -> Maybe Level
levelElemToLevel :: NameSpaces -> Element -> Maybe Level
levelElemToLevel NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"lvl" Element
element = do
      Text
ilvl <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"ilvl" Element
element
      Text
fmt <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"numFmt" Element
element
             forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"val"
      Text
txt <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"lvlText" Element
element
             forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"val"
      let start :: Maybe GridSpan
start = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"start" Element
element
                  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"val"
                  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe GridSpan
stringToInteger
      forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text -> Text -> Maybe GridSpan -> Level
Level Text
ilvl Text
fmt Text
txt Maybe GridSpan
start)
levelElemToLevel NameSpaces
_ Element
_ = forall a. Maybe a
Nothing

archiveToNumbering' :: Archive -> Maybe Numbering
archiveToNumbering' :: Archive -> Maybe Numbering
archiveToNumbering' Archive
zf =
  case [Char] -> Archive -> Maybe Entry
findEntryByPath [Char]
"word/numbering.xml" Archive
zf of
    Maybe Entry
Nothing -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ NameSpaces -> [Numb] -> [AbstractNumb] -> Numbering
Numbering forall a. Monoid a => a
mempty [] []
    Just Entry
entry -> do
      Element
numberingElem <- Entry -> Maybe Element
parseXMLFromEntry Entry
entry
      let namespaces :: NameSpaces
namespaces = Element -> NameSpaces
elemToNameSpaces Element
numberingElem
          numElems :: [Element]
numElems = NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
namespaces Text
"w" Text
"num" Element
numberingElem
          absNumElems :: [Element]
absNumElems = NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
namespaces Text
"w" Text
"abstractNum" Element
numberingElem
          nums :: [Numb]
nums = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NameSpaces -> Element -> Maybe Numb
numElemToNum NameSpaces
namespaces) [Element]
numElems
          absNums :: [AbstractNumb]
absNums = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NameSpaces -> Element -> Maybe AbstractNumb
absNumElemToAbsNum NameSpaces
namespaces) [Element]
absNumElems
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ NameSpaces -> [Numb] -> [AbstractNumb] -> Numbering
Numbering NameSpaces
namespaces [Numb]
nums [AbstractNumb]
absNums

archiveToNumbering :: Archive -> Numbering
archiveToNumbering :: Archive -> Numbering
archiveToNumbering Archive
archive =
  forall a. a -> Maybe a -> a
fromMaybe (NameSpaces -> [Numb] -> [AbstractNumb] -> Numbering
Numbering forall a. Monoid a => a
mempty [] []) (Archive -> Maybe Numbering
archiveToNumbering' Archive
archive)

elemToNotes :: NameSpaces -> Text -> Element -> Maybe (M.Map T.Text Element)
elemToNotes :: NameSpaces -> Text -> Element -> Maybe (Map Text Element)
elemToNotes NameSpaces
ns Text
notetype Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" (Text
notetype forall a. Semigroup a => a -> a -> a
<> Text
"s") Element
element =
      let pairs :: [(Text, Element)]
pairs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                  (\Element
e -> NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                         (\Text
a -> forall a. a -> Maybe a
Just (Text
a, Element
e)))
                  (NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns Text
"w" Text
notetype Element
element)
      in
       forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
       forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text, Element)]
pairs
elemToNotes NameSpaces
_ Text
_ Element
_ = forall a. Maybe a
Nothing

elemToComments :: NameSpaces -> Element -> M.Map T.Text Element
elemToComments :: NameSpaces -> Element -> Map Text Element
elemToComments NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"comments" Element
element =
      let pairs :: [(Text, Element)]
pairs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                  (\Element
e -> NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                         (\Text
a -> forall a. a -> Maybe a
Just (Text
a, Element
e)))
                  (NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns Text
"w" Text
"comment" Element
element)
      in
       forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text, Element)]
pairs
elemToComments NameSpaces
_ Element
_ = forall k a. Map k a
M.empty


---------------------------------------------
---------------------------------------------

elemToTblGrid :: NameSpaces -> Element -> D TblGrid
elemToTblGrid :: NameSpaces -> Element -> D TblGrid
elemToTblGrid NameSpaces
ns Element
element | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"tblGrid" Element
element =
  let cols :: [Element]
cols = NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns Text
"w" Text
"gridCol" Element
element
  in
   forall a b. (a -> D b) -> [a] -> D [b]
mapD (\Element
e -> forall a. Maybe a -> D a
maybeToD (NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"w" Element
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe GridSpan
stringToInteger))
   [Element]
cols
elemToTblGrid NameSpaces
_ Element
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem

elemToTblLook :: NameSpaces -> Element -> D TblLook
elemToTblLook :: NameSpaces -> Element -> D TblLook
elemToTblLook NameSpaces
ns Element
element | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"tblLook" Element
element =
  let firstRow :: Maybe Text
firstRow = NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"firstRow" Element
element
      val :: Maybe Text
val = NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"val" Element
element
      firstRowFmt :: Bool
firstRowFmt =
        case Maybe Text
firstRow of
          Just Text
"1" -> Bool
True
          Just  Text
_  -> Bool
False
          Maybe Text
Nothing -> case Maybe Text
val of
            Just Text
bitMask -> Text -> Int -> Bool
testBitMask Text
bitMask Int
0x020
            Maybe Text
Nothing      -> Bool
False
  in
   forall (m :: * -> *) a. Monad m => a -> m a
return TblLook{firstRowFormatting :: Bool
firstRowFormatting = Bool
firstRowFmt}
elemToTblLook NameSpaces
_ Element
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem

elemToRow :: NameSpaces -> Element -> D Row
elemToRow :: NameSpaces -> Element -> D Row
elemToRow NameSpaces
ns Element
element | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"tr" Element
element =
  do
    let cellElems :: [Element]
cellElems = NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns Text
"w" Text
"tc" Element
element
    [Cell]
cells <- forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D Cell
elemToCell NameSpaces
ns) [Element]
cellElems
    let hasTblHeader :: TblHeader
hasTblHeader = forall b a. b -> (a -> b) -> Maybe a -> b
maybe TblHeader
NoTblHeader (forall a b. a -> b -> a
const TblHeader
HasTblHeader)
          (NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"trPr" Element
element
           forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"tblHeader")
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TblHeader -> [Cell] -> Row
Row TblHeader
hasTblHeader [Cell]
cells
elemToRow NameSpaces
_ Element
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem

elemToCell :: NameSpaces -> Element -> D Cell
elemToCell :: NameSpaces -> Element -> D Cell
elemToCell NameSpaces
ns Element
element | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"tc" Element
element =
  do
    let properties :: Maybe Element
properties = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"tcPr" Element
element
    let gridSpan :: Maybe GridSpan
gridSpan = Maybe Element
properties
                     forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"gridSpan"
                     forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"val"
                     forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe GridSpan
stringToInteger
    let vMerge :: VMerge
vMerge = case Maybe Element
properties forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"vMerge" of
                   Maybe Element
Nothing -> VMerge
Restart
                   Just Element
e ->
                     forall a. a -> Maybe a -> a
fromMaybe VMerge
Continue forall a b. (a -> b) -> a -> b
$ do
                       Text
s <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"val" Element
e
                       case Text
s of
                         Text
"continue" -> forall a. a -> Maybe a
Just VMerge
Continue
                         Text
"restart" -> forall a. a -> Maybe a
Just VMerge
Restart
                         Text
_ -> forall a. Maybe a
Nothing
    [BodyPart]
cellContents <- forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D BodyPart
elemToBodyPart NameSpaces
ns) (Element -> [Element]
elChildren Element
element)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ GridSpan -> VMerge -> [BodyPart] -> Cell
Cell (forall a. a -> Maybe a -> a
fromMaybe GridSpan
1 Maybe GridSpan
gridSpan) VMerge
vMerge [BodyPart]
cellContents
elemToCell NameSpaces
_ Element
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem

testBitMask :: Text -> Int -> Bool
testBitMask :: Text -> Int -> Bool
testBitMask Text
bitMaskS Int
n =
  case (forall a. Read a => ReadS a
reads ([Char]
"0x" forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
bitMaskS) :: [(Int, String)]) of
    []            -> Bool
False
    ((Int
n', [Char]
_) : [(Int, [Char])]
_) -> (Int
n' forall a. Bits a => a -> a -> a
.|. Int
n) forall a. Eq a => a -> a -> Bool
/= Int
0

pHeading :: ParagraphStyle -> Maybe (ParaStyleName, Int)
pHeading :: ParagraphStyle -> Maybe (ParaStyleName, Int)
pHeading = forall a. (ParStyle -> Maybe a) -> [ParStyle] -> Maybe a
getParStyleField ParStyle -> Maybe (ParaStyleName, Int)
headingLev forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParagraphStyle -> [ParStyle]
pStyle

pNumInfo :: ParagraphStyle -> Maybe (T.Text, T.Text)
pNumInfo :: ParagraphStyle -> Maybe (Text, Text)
pNumInfo = forall a. (ParStyle -> Maybe a) -> [ParStyle] -> Maybe a
getParStyleField ParStyle -> Maybe (Text, Text)
numInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParagraphStyle -> [ParStyle]
pStyle

mkListItem :: ParagraphStyle -> Text -> Text -> [ParPart] -> D BodyPart
mkListItem :: ParagraphStyle -> Text -> Text -> [ParPart] -> D BodyPart
mkListItem ParagraphStyle
parstyle Text
numId Text
lvl [ParPart]
parparts = do
  Maybe Level
lvlInfo <- Text -> Text -> Numbering -> Maybe Level
lookupLevel Text
numId Text
lvl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> Numbering
envNumbering
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ParagraphStyle
-> Text -> Text -> Maybe Level -> [ParPart] -> BodyPart
ListItem ParagraphStyle
parstyle Text
numId Text
lvl Maybe Level
lvlInfo [ParPart]
parparts

pStyleIndentation :: ParagraphStyle -> Maybe ParIndentation
pStyleIndentation :: ParagraphStyle -> Maybe ParIndentation
pStyleIndentation ParagraphStyle
style = (forall a. (ParStyle -> Maybe a) -> [ParStyle] -> Maybe a
getParStyleField ParStyle -> Maybe ParIndentation
indent forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParagraphStyle -> [ParStyle]
pStyle) ParagraphStyle
style

elemToBodyPart :: NameSpaces -> Element -> D BodyPart
elemToBodyPart :: NameSpaces -> Element -> D BodyPart
elemToBodyPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"m" Text
"oMathPara" Element
element = do
      [Exp]
expsLst <- forall a b. Either a b -> D b
eitherToD forall a b. (a -> b) -> a -> b
$ Text -> Either Text [Exp]
readOMML forall a b. (a -> b) -> a -> b
$ Element -> Text
showElement Element
element
      ParagraphStyle
parstyle <- NameSpaces -> Element -> ParStyleMap -> Numbering -> ParagraphStyle
elemToParagraphStyle NameSpaces
ns Element
element
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> ParStyleMap
envParStyles
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> Numbering
envNumbering
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ParagraphStyle -> [ParPart] -> BodyPart
Paragraph ParagraphStyle
parstyle [[Exp] -> ParPart
OMathPara [Exp]
expsLst]
elemToBodyPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"p" Element
element
  , Just (Text
numId, Text
lvl) <- NameSpaces -> Element -> Maybe (Text, Text)
getNumInfo NameSpaces
ns Element
element = do
    ParagraphStyle
parstyle <- NameSpaces -> Element -> ParStyleMap -> Numbering -> ParagraphStyle
elemToParagraphStyle NameSpaces
ns Element
element
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> ParStyleMap
envParStyles
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> Numbering
envNumbering
    [ParPart]
parparts <- forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces
-> Element
-> ExceptT
     DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
elemToParPart NameSpaces
ns) (Element -> [Element]
elChildren Element
element)
    case ParagraphStyle -> Maybe (ParaStyleName, Int)
pHeading ParagraphStyle
parstyle of
      Maybe (ParaStyleName, Int)
Nothing -> ParagraphStyle -> Text -> Text -> [ParPart] -> D BodyPart
mkListItem ParagraphStyle
parstyle Text
numId Text
lvl [ParPart]
parparts
      Just (ParaStyleName, Int)
_  -> do
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ParagraphStyle -> [ParPart] -> BodyPart
Paragraph ParagraphStyle
parstyle [ParPart]
parparts
elemToBodyPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"p" Element
element = do
      ParagraphStyle
parstyle <- NameSpaces -> Element -> ParStyleMap -> Numbering -> ParagraphStyle
elemToParagraphStyle NameSpaces
ns Element
element
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> ParStyleMap
envParStyles
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> Numbering
envNumbering

      let hasCaptionStyle :: Bool
hasCaptionStyle = forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ParaStyleId
"Caption" (ParStyle -> ParaStyleId
pStyleId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParagraphStyle -> [ParStyle]
pStyle ParagraphStyle
parstyle)

      let isTableNumberElt :: Element -> Bool
isTableNumberElt el :: Element
el@(Element QName
name [Attr]
attribs [Content]
_ Maybe GridSpan
_) =
           (QName -> Text
qName QName
name forall a. Eq a => a -> a -> Bool
== Text
"fldSimple" Bool -> Bool -> Bool
&&
             case (QName -> Bool) -> [Attr] -> Maybe Text
lookupAttrBy ((forall a. Eq a => a -> a -> Bool
== Text
"instr") forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Text
qName) [Attr]
attribs of
               Maybe Text
Nothing -> Bool
False
               Just Text
instr -> Text
"Table" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Text -> [Text]
T.words Text
instr) Bool -> Bool -> Bool
||
           (QName -> Text
qName QName
name forall a. Eq a => a -> a -> Bool
== Text
"instrText" Bool -> Bool -> Bool
&& Text
"Table" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Text -> [Text]
T.words (Element -> Text
strContent Element
el))

      let isTable :: Bool
isTable = Bool
hasCaptionStyle Bool -> Bool -> Bool
&&
                      forall a. Maybe a -> Bool
isJust ((Element -> Bool) -> Element -> Maybe Element
filterChild Element -> Bool
isTableNumberElt Element
element)

      let stripOffLabel :: [Element] -> [Element]
stripOffLabel = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Bool
isTableNumberElt)

      let children :: [Element]
children = (if Bool
isTable
                          then [Element] -> [Element]
stripOffLabel
                          else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
element
      [ParPart]
parparts' <- forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces
-> Element
-> ExceptT
     DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
elemToParPart NameSpaces
ns) [Element]
children
      [FldCharState]
fldCharState <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ReaderState -> [FldCharState]
stateFldCharState
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ReaderState
st -> ReaderState
st {stateFldCharState :: [FldCharState]
stateFldCharState = [FldCharState] -> [FldCharState]
emptyFldCharContents [FldCharState]
fldCharState}
      -- Word uses list enumeration for numbered headings, so we only
      -- want to infer a list from the styles if it is NOT a heading.
      let parparts :: [ParPart]
parparts = [ParPart]
parparts' forall a. [a] -> [a] -> [a]
++ ([FldCharState] -> [ParPart]
openFldCharsToParParts [FldCharState]
fldCharState)
      case ParagraphStyle -> Maybe (ParaStyleName, Int)
pHeading ParagraphStyle
parstyle of
        Maybe (ParaStyleName, Int)
Nothing | Just (Text
numId, Text
lvl) <- ParagraphStyle -> Maybe (Text, Text)
pNumInfo ParagraphStyle
parstyle -> do
                    ParagraphStyle -> Text -> Text -> [ParPart] -> D BodyPart
mkListItem ParagraphStyle
parstyle Text
numId Text
lvl [ParPart]
parparts
        Maybe (ParaStyleName, Int)
_ -> if Bool
isTable
                then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ParagraphStyle -> [ParPart] -> BodyPart
TblCaption ParagraphStyle
parstyle [ParPart]
parparts
                else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ParagraphStyle -> [ParPart] -> BodyPart
Paragraph ParagraphStyle
parstyle [ParPart]
parparts

elemToBodyPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"tbl" Element
element = do
    let tblProperties :: Maybe Element
tblProperties = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"tblPr" Element
element
        caption :: Text
caption = forall a. a -> Maybe a -> a
fromMaybe Text
"" forall a b. (a -> b) -> a -> b
$ Maybe Element
tblProperties
                   forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"tblCaption"
                   forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"val"
        description :: Text
description = forall a. a -> Maybe a -> a
fromMaybe Text
"" forall a b. (a -> b) -> a -> b
$ Maybe Element
tblProperties
                       forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"tblDescription"
                       forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"val"
        grid' :: D TblGrid
grid' = case NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"tblGrid" Element
element of
          Just Element
g  -> NameSpaces -> Element -> D TblGrid
elemToTblGrid NameSpaces
ns Element
g
          Maybe Element
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
        tblLook' :: D TblLook
tblLook' = case NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"tblPr" Element
element forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                          NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"tblLook"
                     of
                       Just Element
l  -> NameSpaces -> Element -> D TblLook
elemToTblLook NameSpaces
ns Element
l
                       Maybe Element
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return TblLook
defaultTblLook

    TblGrid
grid <- D TblGrid
grid'
    TblLook
tblLook <- D TblLook
tblLook'
    [Row]
rows <- forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D Row
elemToRow NameSpaces
ns) (Element -> [Element]
elChildren Element
element)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> TblGrid -> TblLook -> [Row] -> BodyPart
Tbl (Text
caption forall a. Semigroup a => a -> a -> a
<> Text
description) TblGrid
grid TblLook
tblLook [Row]
rows
elemToBodyPart NameSpaces
_ Element
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem

lookupRelationship :: DocumentLocation -> RelId -> [Relationship] -> Maybe Target
lookupRelationship :: DocumentLocation -> Text -> [Relationship] -> Maybe Text
lookupRelationship DocumentLocation
docLocation Text
relid [Relationship]
rels =
  forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (DocumentLocation
docLocation, Text
relid) [((DocumentLocation, Text), Text)]
pairs
  where
    pairs :: [((DocumentLocation, Text), Text)]
pairs = forall a b. (a -> b) -> [a] -> [b]
map (\(Relationship DocumentLocation
loc Text
relid' Text
target) -> ((DocumentLocation
loc, Text
relid'), Text
target)) [Relationship]
rels

openFldCharsToParParts :: [FldCharState] -> [ParPart]
openFldCharsToParParts :: [FldCharState] -> [ParPart]
openFldCharsToParParts [] = []
openFldCharsToParParts (FldCharContent FieldInfo
info [ParPart]
children : [FldCharState]
ancestors) = case [FldCharState] -> [ParPart]
openFldCharsToParParts [FldCharState]
ancestors of
  Field FieldInfo
parentInfo [ParPart]
siblings : [ParPart]
_ -> [FieldInfo -> [ParPart] -> ParPart
Field FieldInfo
parentInfo forall a b. (a -> b) -> a -> b
$ [ParPart]
siblings forall a. [a] -> [a] -> [a]
++ [FieldInfo -> [ParPart] -> ParPart
Field FieldInfo
info forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [ParPart]
children]]
  [ParPart]
_ -> [FieldInfo -> [ParPart] -> ParPart
Field FieldInfo
info forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [ParPart]
children]
openFldCharsToParParts (FldCharState
_ : [FldCharState]
ancestors) = [FldCharState] -> [ParPart]
openFldCharsToParParts [FldCharState]
ancestors

emptyFldCharContents :: [FldCharState] -> [FldCharState]
emptyFldCharContents :: [FldCharState] -> [FldCharState]
emptyFldCharContents = forall a b. (a -> b) -> [a] -> [b]
map
  (\FldCharState
x -> case FldCharState
x of
    FldCharContent FieldInfo
info [ParPart]
_ -> FieldInfo -> [ParPart] -> FldCharState
FldCharContent FieldInfo
info []
    FldCharState
_ -> FldCharState
x)

expandDrawingId :: T.Text -> D (FilePath, B.ByteString)
expandDrawingId :: Text -> D ([Char], ByteString)
expandDrawingId Text
s = do
  DocumentLocation
location <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> DocumentLocation
envLocation
  Maybe [Char]
target <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocumentLocation -> Text -> [Relationship] -> Maybe Text
lookupRelationship DocumentLocation
location Text
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderEnv -> [Relationship]
envRelationships)
  case Maybe [Char]
target of
    Just [Char]
filepath -> do
      Media
media <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> Media
envMedia
      let filepath' :: [Char]
filepath' = case [Char]
filepath of
                        (Char
'/':[Char]
rest) -> [Char]
rest
                        [Char]
_ -> [Char]
"word/" forall a. [a] -> [a] -> [a]
++ [Char]
filepath
      case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
filepath' Media
media of
        Just ByteString
bs -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
filepath, ByteString
bs)
        Maybe ByteString
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
DocxError
    Maybe [Char]
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
DocxError

getTitleAndAlt :: NameSpaces -> Element -> (T.Text, T.Text)
getTitleAndAlt :: NameSpaces -> Element -> (Text, Text)
getTitleAndAlt NameSpaces
ns Element
element =
  let mbDocPr :: Maybe Element
mbDocPr = (NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"wp" Text
"inline" Element
element forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>   -- Word
                 NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"wp" Text
"anchor" Element
element) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=  -- LibreOffice
                NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"wp" Text
"docPr"
      title :: Text
title = forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Element
mbDocPr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"" Text
"title")
      alt :: Text
alt = forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Element
mbDocPr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"" Text
"descr")
  in (Text
title, Text
alt)

elemToParPart :: NameSpaces -> Element -> D [ParPart]
{-
The next one is a bit complicated. fldChar fields work by first
having a <w:fldChar fldCharType="begin"> in a run, then a run with
<w:instrText>, then a <w:fldChar fldCharType="separate"> run, then the
content runs, and finally a <w:fldChar fldCharType="end"> run. For
example (omissions and my comments in brackets):

      <w:r>
        [...]
        <w:fldChar w:fldCharType="begin"/>
      </w:r>
      <w:r>
        [...]
        <w:instrText xml:space="preserve"> HYPERLINK [hyperlink url] </w:instrText>
      </w:r>
      <w:r>
        [...]
        <w:fldChar w:fldCharType="separate"/>
      </w:r>
      <w:r w:rsidRPr=[...]>
        [...]
        <w:t>Foundations of Analysis, 2nd Edition</w:t>
      </w:r>
      <w:r>
        [...]
        <w:fldChar w:fldCharType="end"/>
      </w:r>

So we do this in a number of steps. If we encounter the fldchar begin
tag, we start open a fldchar state variable (see state above). We add
the instrtext to it as FieldInfo. Then we close that and start adding
the children when we get to separate. Then when we get to end, we produce
the Field type with appropriate FieldInfo and ParParts.

Since there can be nested fields, the fldchar state needs to be a stack,
so we can have multiple fldchars open at the same time. When a fldchar is
closed, we either add the resulting field to its parent or we return it if
there is no parent.
-}
elemToParPart :: NameSpaces
-> Element
-> ExceptT
     DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
elemToParPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
fldChar <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"fldChar" Element
element
  , Just Text
fldCharType <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"fldCharType" Element
fldChar = do
      [FldCharState]
fldCharState <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ReaderState -> [FldCharState]
stateFldCharState
      case [FldCharState]
fldCharState of
        [FldCharState]
_ | Text
fldCharType forall a. Eq a => a -> a -> Bool
== Text
"begin" -> do
          forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ReaderState
st -> ReaderState
st {stateFldCharState :: [FldCharState]
stateFldCharState = FldCharState
FldCharOpen forall a. a -> [a] -> [a]
: [FldCharState]
fldCharState}
          forall (m :: * -> *) a. Monad m => a -> m a
return []
        FldCharFieldInfo FieldInfo
info : [FldCharState]
ancestors | Text
fldCharType forall a. Eq a => a -> a -> Bool
== Text
"separate" -> do
          forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ReaderState
st -> ReaderState
st {stateFldCharState :: [FldCharState]
stateFldCharState = FieldInfo -> [ParPart] -> FldCharState
FldCharContent FieldInfo
info [] forall a. a -> [a] -> [a]
: [FldCharState]
ancestors}
          forall (m :: * -> *) a. Monad m => a -> m a
return []
        -- Some fields have no content, since Pandoc doesn't understand any of those fields, we can just close it.
        FldCharFieldInfo FieldInfo
_ : [FldCharState]
ancestors | Text
fldCharType forall a. Eq a => a -> a -> Bool
== Text
"end" -> do
          forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ReaderState
st -> ReaderState
st {stateFldCharState :: [FldCharState]
stateFldCharState = [FldCharState]
ancestors}
          forall (m :: * -> *) a. Monad m => a -> m a
return []
        [FldCharContent FieldInfo
info [ParPart]
children] | Text
fldCharType forall a. Eq a => a -> a -> Bool
== Text
"end" -> do
          forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ReaderState
st -> ReaderState
st {stateFldCharState :: [FldCharState]
stateFldCharState = []}
          forall (m :: * -> *) a. Monad m => a -> m a
return [FieldInfo -> [ParPart] -> ParPart
Field FieldInfo
info forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [ParPart]
children]
        FldCharContent FieldInfo
info [ParPart]
children : FldCharContent FieldInfo
parentInfo [ParPart]
siblings : [FldCharState]
ancestors | Text
fldCharType forall a. Eq a => a -> a -> Bool
== Text
"end" ->
          let parent :: FldCharState
parent = FieldInfo -> [ParPart] -> FldCharState
FldCharContent FieldInfo
parentInfo forall a b. (a -> b) -> a -> b
$ (FieldInfo -> [ParPart] -> ParPart
Field FieldInfo
info (forall a. [a] -> [a]
reverse [ParPart]
children)) forall a. a -> [a] -> [a]
: [ParPart]
siblings in do
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ReaderState
st -> ReaderState
st {stateFldCharState :: [FldCharState]
stateFldCharState = FldCharState
parent forall a. a -> [a] -> [a]
: [FldCharState]
ancestors}
            forall (m :: * -> *) a. Monad m => a -> m a
return []
        [FldCharState]
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
elemToParPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
instrText <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"instrText" Element
element = do
      [FldCharState]
fldCharState <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ReaderState -> [FldCharState]
stateFldCharState
      case [FldCharState]
fldCharState of
        FldCharState
FldCharOpen : [FldCharState]
ancestors -> do
          FieldInfo
info <- forall a b. Either a b -> D b
eitherToD forall a b. (a -> b) -> a -> b
$ Text -> Either ParseError FieldInfo
parseFieldInfo forall a b. (a -> b) -> a -> b
$ Element -> Text
strContent Element
instrText
          forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ReaderState
st -> ReaderState
st {stateFldCharState :: [FldCharState]
stateFldCharState = FieldInfo -> FldCharState
FldCharFieldInfo FieldInfo
info forall a. a -> [a] -> [a]
: [FldCharState]
ancestors}
          forall (m :: * -> *) a. Monad m => a -> m a
return []
        [FldCharState]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
{-
There is an open fldchar, so we calculate the element and add it to the
children. For this we need to first change the fldchar state to an empty
stack to avoid descendants of children simply being added to the state instead
of to their direct parent element. This would happen in the case of a
w:hyperlink element for example.
-}
elemToParPart NameSpaces
ns Element
element = do
  [FldCharState]
fldCharState <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ReaderState -> [FldCharState]
stateFldCharState
  case [FldCharState]
fldCharState of
    FldCharContent FieldInfo
info [ParPart]
children : [FldCharState]
ancestors -> do
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ReaderState
st -> ReaderState
st {stateFldCharState :: [FldCharState]
stateFldCharState = []}
      [ParPart]
parParts <- NameSpaces
-> Element
-> ExceptT
     DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
elemToParPart' NameSpaces
ns Element
element forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \DocxError
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ReaderState
st -> ReaderState
st{stateFldCharState :: [FldCharState]
stateFldCharState = FieldInfo -> [ParPart] -> FldCharState
FldCharContent FieldInfo
info ([ParPart]
parParts forall a. [a] -> [a] -> [a]
++ [ParPart]
children) forall a. a -> [a] -> [a]
: [FldCharState]
ancestors}
      forall (m :: * -> *) a. Monad m => a -> m a
return []
    [FldCharState]
_ -> NameSpaces
-> Element
-> ExceptT
     DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
elemToParPart' NameSpaces
ns Element
element

elemToParPart' :: NameSpaces -> Element -> D [ParPart]
elemToParPart' :: NameSpaces
-> Element
-> ExceptT
     DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
elemToParPart' NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
drawingElem <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"drawing" Element
element
  , Text
pic_ns <- Text
"http://schemas.openxmlformats.org/drawingml/2006/picture"
  , [Element]
picElems <- QName -> Element -> [Element]
findElements (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"pic" (forall a. a -> Maybe a
Just Text
pic_ns) (forall a. a -> Maybe a
Just Text
"pic")) Element
drawingElem
  = let (Text
title, Text
alt) = NameSpaces -> Element -> (Text, Text)
getTitleAndAlt NameSpaces
ns Element
drawingElem
        drawings :: [(Maybe Text, Element)]
drawings = forall a b. (a -> b) -> [a] -> [b]
map (\Element
el ->
                        ((Element -> Maybe Element
findBlip Element
el forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"r" Text
"embed"), Element
el))
                       [Element]
picElems
    in forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\case
                (Just Text
s, Element
el) -> do
                  ([Char]
fp, ByteString
bs) <- Text -> D ([Char], ByteString)
expandDrawingId Text
s
                  let extent :: Extent
extent = Element -> Extent
elemToExtent Element
el forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Element -> Extent
elemToExtent Element
element
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Text -> Text -> ByteString -> Extent -> ParPart
Drawing [Char]
fp Text
title Text
alt ByteString
bs Extent
extent
                (Maybe Text
Nothing, Element
_) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem)
            [(Maybe Text, Element)]
drawings
-- The two cases below are an attempt to deal with images in deprecated vml format.
-- Todo: check out title and attr for deprecated format.
elemToParPart' NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
_ <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"pict" Element
element =
    let drawing :: Maybe Text
drawing = QName -> Element -> Maybe Element
findElement (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns Text
"v" Text
"imagedata") Element
element
                  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"r" Text
"id"
    in
     case Maybe Text
drawing of
       Just Text
s -> Text -> D ([Char], ByteString)
expandDrawingId Text
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\([Char]
fp, ByteString
bs) -> forall (m :: * -> *) a. Monad m => a -> m a
return [[Char] -> Text -> Text -> ByteString -> Extent -> ParPart
Drawing [Char]
fp Text
"" Text
"" ByteString
bs forall a. Maybe a
Nothing])
       Maybe Text
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
elemToParPart' NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
objectElem <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"object" Element
element
  , Just Element
shapeElem <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"v" Text
"shape" Element
objectElem
  , Just Element
imagedataElem <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"v" Text
"imagedata" Element
shapeElem
  , Just Text
drawingId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"r" Text
"id" Element
imagedataElem
  = Text -> D ([Char], ByteString)
expandDrawingId Text
drawingId forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\([Char]
fp, ByteString
bs) -> forall (m :: * -> *) a. Monad m => a -> m a
return [[Char] -> Text -> Text -> ByteString -> Extent -> ParPart
Drawing [Char]
fp Text
"" Text
"" ByteString
bs forall a. Maybe a
Nothing])
-- Diagram
elemToParPart' NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
drawingElem <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"drawing" Element
element
  , Text
d_ns <- Text
"http://schemas.openxmlformats.org/drawingml/2006/diagram"
  , Just Element
_ <- QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"relIds" (forall a. a -> Maybe a
Just Text
d_ns) (forall a. a -> Maybe a
Just Text
"dgm")) Element
drawingElem
  = forall (m :: * -> *) a. Monad m => a -> m a
return [ParPart
Diagram]
-- Chart
elemToParPart' NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
drawingElem <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"drawing" Element
element
  , Text
c_ns <- Text
"http://schemas.openxmlformats.org/drawingml/2006/chart"
  , Just Element
_ <- QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"chart" (forall a. a -> Maybe a
Just Text
c_ns) (forall a. a -> Maybe a
Just Text
"c")) Element
drawingElem
  = forall (m :: * -> *) a. Monad m => a -> m a
return [ParPart
Chart]
elemToParPart' NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element = do
    [Run]
runs <- NameSpaces -> Element -> D [Run]
elemToRun NameSpaces
ns Element
element
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Run -> ParPart
PlainRun [Run]
runs
elemToParPart' NameSpaces
ns Element
element
  | Just TrackedChange
change <- NameSpaces -> Element -> Maybe TrackedChange
getTrackedChange NameSpaces
ns Element
element = do
      [Run]
runs <- forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D [Run]
elemToRun NameSpaces
ns) (Element -> [Element]
elChildren Element
element)
      forall (m :: * -> *) a. Monad m => a -> m a
return [TrackedChange -> [Run] -> ParPart
ChangedRuns TrackedChange
change [Run]
runs]
elemToParPart' NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"bookmarkStart" Element
element
  , Just Text
bmId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
element
  , Just Text
bmName <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"name" Element
element =
    forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> Text -> ParPart
BookMark Text
bmId Text
bmName]
elemToParPart' NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"hyperlink" Element
element
  , Just Text
relId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"r" Text
"id" Element
element = do
    DocumentLocation
location <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> DocumentLocation
envLocation
    [ParPart]
children <- forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces
-> Element
-> ExceptT
     DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
elemToParPart NameSpaces
ns) (Element -> [Element]
elChildren Element
element)
    [Relationship]
rels <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> [Relationship]
envRelationships
    case DocumentLocation -> Text -> [Relationship] -> Maybe Text
lookupRelationship DocumentLocation
location Text
relId [Relationship]
rels of
      Just Text
target ->
         case NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"anchor" Element
element of
             Just Text
anchor -> forall (m :: * -> *) a. Monad m => a -> m a
return
               [Text -> [ParPart] -> ParPart
ExternalHyperLink (Text
target forall a. Semigroup a => a -> a -> a
<> Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
anchor) [ParPart]
children]
             Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> [ParPart] -> ParPart
ExternalHyperLink Text
target [ParPart]
children]
      Maybe Text
Nothing     -> forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> [ParPart] -> ParPart
ExternalHyperLink Text
"" [ParPart]
children]
elemToParPart' NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"hyperlink" Element
element
  , Just Text
anchor <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"anchor" Element
element = do
    [ParPart]
children <- forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces
-> Element
-> ExceptT
     DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
elemToParPart NameSpaces
ns) (Element -> [Element]
elChildren Element
element)
    forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> [ParPart] -> ParPart
InternalHyperLink Text
anchor [ParPart]
children]
elemToParPart' NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"commentRangeStart" Element
element
  , Just Text
cmtId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
element = do
      (Comments NameSpaces
_ Map Text Element
commentMap) <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> Comments
envComments
      case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
cmtId Map Text Element
commentMap of
        Just Element
cmtElem -> NameSpaces
-> Element
-> ExceptT
     DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
elemToCommentStart NameSpaces
ns Element
cmtElem
        Maybe Element
Nothing      -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
elemToParPart' NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"commentRangeEnd" Element
element
  , Just Text
cmtId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
element =
    forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> ParPart
CommentEnd Text
cmtId]
elemToParPart' NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"m" Text
"oMath" Element
element =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> ParPart
PlainOMath) (forall a b. Either a b -> D b
eitherToD forall a b. (a -> b) -> a -> b
$ Text -> Either Text [Exp]
readOMML forall a b. (a -> b) -> a -> b
$ Element -> Text
showElement Element
element)
elemToParPart' NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"m" Text
"oMathPara" Element
element =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> ParPart
OMathPara) (forall a b. Either a b -> D b
eitherToD forall a b. (a -> b) -> a -> b
$ Text -> Either Text [Exp]
readOMML forall a b. (a -> b) -> a -> b
$ Element -> Text
showElement Element
element)
elemToParPart' NameSpaces
_ Element
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem

elemToCommentStart :: NameSpaces -> Element -> D [ParPart]
elemToCommentStart :: NameSpaces
-> Element
-> ExceptT
     DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
elemToCommentStart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"comment" Element
element
  , Just Text
cmtId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
element
  , Just Text
cmtAuthor <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"author" Element
element
  , Maybe Text
cmtDate <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"date" Element
element = do
      [BodyPart]
bps <- forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D BodyPart
elemToBodyPart NameSpaces
ns) (Element -> [Element]
elChildren Element
element)
      forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> Text -> Maybe Text -> [BodyPart] -> ParPart
CommentStart Text
cmtId Text
cmtAuthor Maybe Text
cmtDate [BodyPart]
bps]
elemToCommentStart NameSpaces
_ Element
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem

lookupFootnote :: T.Text -> Notes -> Maybe Element
lookupFootnote :: Text -> Notes -> Maybe Element
lookupFootnote Text
s (Notes NameSpaces
_ Maybe (Map Text Element)
fns Maybe (Map Text Element)
_) = Maybe (Map Text Element)
fns forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
s

lookupEndnote :: T.Text -> Notes -> Maybe Element
lookupEndnote :: Text -> Notes -> Maybe Element
lookupEndnote Text
s (Notes NameSpaces
_ Maybe (Map Text Element)
_ Maybe (Map Text Element)
ens) = Maybe (Map Text Element)
ens forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
s

elemToExtent :: Element -> Extent
elemToExtent :: Element -> Extent
elemToExtent Element
el =
  case (forall {b}. Read b => Text -> Maybe b
getDim Text
"cx", forall {b}. Read b => Text -> Maybe b
getDim Text
"cy") of
    (Just Double
w, Just Double
h) -> forall a. a -> Maybe a
Just (Double
w, Double
h)
    (Maybe Double, Maybe Double)
_                -> forall a. Maybe a
Nothing
 where
  getDim :: Text -> Maybe b
getDim Text
at = (QName -> Bool) -> Element -> Maybe Element
filterElementName (\QName
n -> QName -> Text
qName QName
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"extent", Text
"ext"]) Element
el
              forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName Text
at forall a. Maybe a
Nothing forall a. Maybe a
Nothing) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead


childElemToRun :: NameSpaces -> Element -> D [Run]
childElemToRun :: NameSpaces -> Element -> D [Run]
childElemToRun NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"drawing" Element
element
  , Text
pic_ns <- Text
"http://schemas.openxmlformats.org/drawingml/2006/picture"
  , [Element]
picElems <- QName -> Element -> [Element]
findElements (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"pic" (forall a. a -> Maybe a
Just Text
pic_ns) (forall a. a -> Maybe a
Just Text
"pic")) Element
element
  = let (Text
title, Text
alt) = NameSpaces -> Element -> (Text, Text)
getTitleAndAlt NameSpaces
ns Element
element
        drawings :: [(Maybe Text, Element)]
drawings = forall a b. (a -> b) -> [a] -> [b]
map (\Element
el ->
                         ((Element -> Maybe Element
findBlip Element
el forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"r" Text
"embed"), Element
el))
                   [Element]
picElems
    in forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\case
                (Just Text
s, Element
el) -> do
                  ([Char]
fp, ByteString
bs) <- Text -> D ([Char], ByteString)
expandDrawingId Text
s
                  let extent :: Extent
extent = Element -> Extent
elemToExtent Element
el forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Element -> Extent
elemToExtent Element
element
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> Text -> Text -> ByteString -> Extent -> Run
InlineDrawing [Char]
fp Text
title Text
alt ByteString
bs Extent
extent
                (Maybe Text
Nothing, Element
_) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem)
       [(Maybe Text, Element)]
drawings
childElemToRun NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"drawing" Element
element
  , Text
c_ns <- Text
"http://schemas.openxmlformats.org/drawingml/2006/chart"
  , Just Element
_ <- QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"chart" (forall a. a -> Maybe a
Just Text
c_ns) (forall a. a -> Maybe a
Just Text
"c")) Element
element
  = forall (m :: * -> *) a. Monad m => a -> m a
return [Run
InlineChart]
childElemToRun NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"drawing" Element
element
  , Text
c_ns <- Text
"http://schemas.openxmlformats.org/drawingml/2006/diagram"
  , Just Element
_ <- QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"relIds" (forall a. a -> Maybe a
Just Text
c_ns) (forall a. a -> Maybe a
Just Text
"dgm")) Element
element
  = forall (m :: * -> *) a. Monad m => a -> m a
return [Run
InlineDiagram]
childElemToRun NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"footnoteReference" Element
element
  , Just Text
fnId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
element = do
    Notes
notes <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> Notes
envNotes
    case Text -> Notes -> Maybe Element
lookupFootnote Text
fnId Notes
notes of
      Just Element
e -> do [BodyPart]
bps <- forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ReaderEnv
r -> ReaderEnv
r {envLocation :: DocumentLocation
envLocation=DocumentLocation
InFootnote}) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D BodyPart
elemToBodyPart NameSpaces
ns) (Element -> [Element]
elChildren Element
e)
                   forall (m :: * -> *) a. Monad m => a -> m a
return [[BodyPart] -> Run
Footnote [BodyPart]
bps]
      Maybe Element
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return [[BodyPart] -> Run
Footnote []]
childElemToRun NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"endnoteReference" Element
element
  , Just Text
enId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
element = do
    Notes
notes <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> Notes
envNotes
    case Text -> Notes -> Maybe Element
lookupEndnote Text
enId Notes
notes of
      Just Element
e -> do [BodyPart]
bps <- forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ReaderEnv
r -> ReaderEnv
r {envLocation :: DocumentLocation
envLocation=DocumentLocation
InEndnote}) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D BodyPart
elemToBodyPart NameSpaces
ns) (Element -> [Element]
elChildren Element
e)
                   forall (m :: * -> *) a. Monad m => a -> m a
return [[BodyPart] -> Run
Endnote [BodyPart]
bps]
      Maybe Element
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return [[BodyPart] -> Run
Endnote []]
childElemToRun NameSpaces
_ Element
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem

elemToRun :: NameSpaces -> Element -> D [Run]
elemToRun :: NameSpaces -> Element -> D [Run]
elemToRun NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
altCont <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"mc" Text
"AlternateContent" Element
element =
    do let choices :: [Element]
choices = NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns Text
"mc" Text
"Choice" Element
altCont
           choiceChildren :: [Element]
choiceChildren = forall a b. (a -> b) -> [a] -> [b]
map forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Element -> [Element]
elChildren [Element]
choices
       [[Run]]
outputs <- forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D [Run]
childElemToRun NameSpaces
ns) [Element]
choiceChildren
       case [[Run]]
outputs of
         [Run]
r : [[Run]]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return [Run]
r
         []    -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
elemToRun NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
drawingElem <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"drawing" Element
element =
    NameSpaces -> Element -> D [Run]
childElemToRun NameSpaces
ns Element
drawingElem
elemToRun NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
ref <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"footnoteReference" Element
element =
    NameSpaces -> Element -> D [Run]
childElemToRun NameSpaces
ns Element
ref
elemToRun NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
ref <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"endnoteReference" Element
element =
    NameSpaces -> Element -> D [Run]
childElemToRun NameSpaces
ns Element
ref
elemToRun NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element = do
    [RunElem]
runElems <- NameSpaces -> Element -> D [RunElem]
elemToRunElems NameSpaces
ns Element
element
    RunStyle
runStyle <- NameSpaces -> Element -> D RunStyle
elemToRunStyleD NameSpaces
ns Element
element
    forall (m :: * -> *) a. Monad m => a -> m a
return [RunStyle -> [RunElem] -> Run
Run RunStyle
runStyle [RunElem]
runElems]
elemToRun NameSpaces
_ Element
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem

getParentStyleValue :: (ParStyle -> Maybe a) -> ParStyle -> Maybe a
getParentStyleValue :: forall a. (ParStyle -> Maybe a) -> ParStyle -> Maybe a
getParentStyleValue ParStyle -> Maybe a
field ParStyle
style
  | Just a
value <- ParStyle -> Maybe a
field ParStyle
style = forall a. a -> Maybe a
Just a
value
  | Just ParStyle
parentStyle <- ParStyle -> Maybe ParStyle
psParentStyle ParStyle
style
                      = forall a. (ParStyle -> Maybe a) -> ParStyle -> Maybe a
getParentStyleValue ParStyle -> Maybe a
field ParStyle
parentStyle
getParentStyleValue ParStyle -> Maybe a
_ ParStyle
_ = forall a. Maybe a
Nothing

getParStyleField :: (ParStyle -> Maybe a) -> [ParStyle] -> Maybe a
getParStyleField :: forall a. (ParStyle -> Maybe a) -> [ParStyle] -> Maybe a
getParStyleField ParStyle -> Maybe a
field [ParStyle]
styles
  | (a
y:[a]
_) <- forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. (ParStyle -> Maybe a) -> ParStyle -> Maybe a
getParentStyleValue ParStyle -> Maybe a
field) [ParStyle]
styles
           = forall a. a -> Maybe a
Just a
y
getParStyleField ParStyle -> Maybe a
_ [ParStyle]
_ = forall a. Maybe a
Nothing

getTrackedChange :: NameSpaces -> Element -> Maybe TrackedChange
getTrackedChange :: NameSpaces -> Element -> Maybe TrackedChange
getTrackedChange NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"ins" Element
element Bool -> Bool -> Bool
|| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"moveTo" Element
element
  , Just Text
cId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
element
  , Just Text
cAuthor <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"author" Element
element
  , Maybe Text
mcDate <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"date" Element
element =
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ChangeType -> ChangeInfo -> TrackedChange
TrackedChange ChangeType
Insertion (Text -> Text -> Maybe Text -> ChangeInfo
ChangeInfo Text
cId Text
cAuthor Maybe Text
mcDate)
getTrackedChange NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"del" Element
element Bool -> Bool -> Bool
|| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"moveFrom" Element
element
  , Just Text
cId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
element
  , Just Text
cAuthor <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"author" Element
element
  , Maybe Text
mcDate <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"date" Element
element =
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ChangeType -> ChangeInfo -> TrackedChange
TrackedChange ChangeType
Deletion (Text -> Text -> Maybe Text -> ChangeInfo
ChangeInfo Text
cId Text
cAuthor Maybe Text
mcDate)
getTrackedChange NameSpaces
_ Element
_ = forall a. Maybe a
Nothing

elemToParagraphStyle :: NameSpaces -> Element
                     -> ParStyleMap
                     -> Numbering
                     -> ParagraphStyle
elemToParagraphStyle :: NameSpaces -> Element -> ParStyleMap -> Numbering -> ParagraphStyle
elemToParagraphStyle NameSpaces
ns Element
element ParStyleMap
sty Numbering
numbering
  | Just Element
pPr <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"pPr" Element
element =
    let style :: [ParaStyleId]
style =
          forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
          (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ParaStyleId
ParaStyleId forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"val")
          (NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns Text
"w" Text
"pStyle" Element
pPr)
        pStyle' :: [ParStyle]
pStyle' = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` ParStyleMap
sty) [ParaStyleId]
style
    in ParagraphStyle
      {pStyle :: [ParStyle]
pStyle = [ParStyle]
pStyle'
      , numbered :: Bool
numbered = case NameSpaces -> Element -> Maybe (Text, Text)
getNumInfo NameSpaces
ns Element
element of
          Just (Text
numId, Text
lvl) -> forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ Text -> Text -> Numbering -> Maybe Level
lookupLevel Text
numId Text
lvl Numbering
numbering
          Maybe (Text, Text)
Nothing -> forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall a. (ParStyle -> Maybe a) -> [ParStyle] -> Maybe a
getParStyleField ParStyle -> Maybe (Text, Text)
numInfo [ParStyle]
pStyle'
      , indentation :: Maybe ParIndentation
indentation =
          NameSpaces -> Element -> Maybe ParIndentation
getIndentation NameSpaces
ns Element
element
      , dropCap :: Bool
dropCap =
          case
            NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"framePr" Element
pPr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"dropCap"
          of
            Just Text
"none" -> Bool
False
            Just Text
_      -> Bool
True
            Maybe Text
Nothing     -> Bool
False
      , pChange :: Maybe TrackedChange
pChange     = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"rPr" Element
pPr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                      (Element -> Bool) -> Element -> Maybe Element
filterChild (\Element
e -> NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"ins" Element
e Bool -> Bool -> Bool
||
                                         NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"moveTo" Element
e Bool -> Bool -> Bool
||
                                         NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"del" Element
e Bool -> Bool -> Bool
||
                                         NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"moveFrom" Element
e
                                  ) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                      NameSpaces -> Element -> Maybe TrackedChange
getTrackedChange NameSpaces
ns
      , pBidi :: Maybe Bool
pBidi = NameSpaces -> Element -> QName -> Maybe Bool
checkOnOff NameSpaces
ns Element
pPr (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns Text
"w" Text
"bidi")
      }
  | Bool
otherwise = ParagraphStyle
defaultParagraphStyle

elemToRunStyleD :: NameSpaces -> Element -> D RunStyle
elemToRunStyleD :: NameSpaces -> Element -> D RunStyle
elemToRunStyleD NameSpaces
ns Element
element
  | Just Element
rPr <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"rPr" Element
element = do
    CharStyleMap
charStyles <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> CharStyleMap
envCharStyles
    let parentSty :: Maybe CharStyle
parentSty =
          NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"rStyle" Element
rPr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"val" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup CharStyleMap
charStyles forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> CharStyleId
CharStyleId
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ NameSpaces -> Element -> Maybe CharStyle -> RunStyle
elemToRunStyle NameSpaces
ns Element
element Maybe CharStyle
parentSty
elemToRunStyleD NameSpaces
_ Element
_ = forall (m :: * -> *) a. Monad m => a -> m a
return RunStyle
defaultRunStyle

elemToRunElem :: NameSpaces -> Element -> D RunElem
elemToRunElem :: NameSpaces -> Element -> D RunElem
elemToRunElem NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"t" Element
element
    Bool -> Bool -> Bool
|| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"delText" Element
element
    Bool -> Bool -> Bool
|| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"m" Text
"t" Element
element = do
    let str :: Text
str = Element -> Text
strContent Element
element
    Maybe Font
font <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> Maybe Font
envFont
    case Maybe Font
font of
      Maybe Font
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> RunElem
TextRun Text
str
      Just Font
f  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> RunElem
TextRun forall a b. (a -> b) -> a -> b
$
                  (Char -> Char) -> Text -> Text
T.map (\Char
x -> forall a. a -> Maybe a -> a
fromMaybe Char
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. Font -> Char -> Maybe Char
getUnicode Font
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
lowerFromPrivate forall a b. (a -> b) -> a -> b
$ Char
x) Text
str
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"br" Element
element = forall (m :: * -> *) a. Monad m => a -> m a
return RunElem
LnBrk
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"tab" Element
element = forall (m :: * -> *) a. Monad m => a -> m a
return RunElem
Tab
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"softHyphen" Element
element = forall (m :: * -> *) a. Monad m => a -> m a
return RunElem
SoftHyphen
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"noBreakHyphen" Element
element = forall (m :: * -> *) a. Monad m => a -> m a
return RunElem
NoBreakHyphen
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"sym" Element
element = forall (m :: * -> *) a. Monad m => a -> m a
return (NameSpaces -> Element -> RunElem
getSymChar NameSpaces
ns Element
element)
  | Bool
otherwise = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
  where
    lowerFromPrivate :: Char -> Char
lowerFromPrivate (Char -> Int
ord -> Int
c)
      | Int
c forall a. Ord a => a -> a -> Bool
>= Char -> Int
ord Char
'\xF000' = Int -> Char
chr forall a b. (a -> b) -> a -> b
$ Int
c forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'\xF000'
      | Bool
otherwise = Int -> Char
chr Int
c

-- The char attribute is a hex string
getSymChar :: NameSpaces -> Element -> RunElem
getSymChar :: NameSpaces -> Element -> RunElem
getSymChar NameSpaces
ns Element
element
  | Just Text
s <- Text -> Text
lowerFromPrivate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
getCodepoint
  , Just Font
font <- Maybe Font
getFont =
    case ReadS Char
readLitChar ([Char]
"\\x" forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
s) of
         [(Char
char, [Char]
_)] -> Text -> RunElem
TextRun forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Char -> Text
T.singleton forall a b. (a -> b) -> a -> b
$ Font -> Char -> Maybe Char
getUnicode Font
font Char
char
         [(Char, [Char])]
_           -> Text -> RunElem
TextRun Text
""
  where
    getCodepoint :: Maybe Text
getCodepoint = NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"char" Element
element
    getFont :: Maybe Font
getFont = Text -> Maybe Font
textToFont forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"font" Element
element
    lowerFromPrivate :: Text -> Text
lowerFromPrivate Text
t | Text
"F" Text -> Text -> Bool
`T.isPrefixOf` Text
t = Text
"0" forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.drop Int
1 Text
t
                       | Bool
otherwise             = Text
t
getSymChar NameSpaces
_ Element
_ = Text -> RunElem
TextRun Text
""

elemToRunElems :: NameSpaces -> Element -> D [RunElem]
elemToRunElems :: NameSpaces -> Element -> D [RunElem]
elemToRunElems NameSpaces
ns Element
element
  |  NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
     Bool -> Bool -> Bool
|| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"m" Text
"r" Element
element = do
       let qualName :: Text -> QName
qualName = NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns Text
"w"
       let font :: Maybe Font
font = do
                    Element
fontElem <- QName -> Element -> Maybe Element
findElement (Text -> QName
qualName Text
"rFonts") Element
element
                    Text -> Maybe Font
textToFont forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                       forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b c. (a -> b -> c) -> b -> a -> c
flip QName -> Element -> Maybe Text
findAttr Element
fontElem forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> QName
qualName))
                         forall a. Maybe a
Nothing [Text
"ascii", Text
"hAnsi"]
       forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Maybe Font -> ReaderEnv -> ReaderEnv
setFont Maybe Font
font) (forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D RunElem
elemToRunElem NameSpaces
ns) (Element -> [Element]
elChildren Element
element))
elemToRunElems NameSpaces
_ Element
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem

setFont :: Maybe Font -> ReaderEnv -> ReaderEnv
setFont :: Maybe Font -> ReaderEnv -> ReaderEnv
setFont Maybe Font
f ReaderEnv
s = ReaderEnv
s{envFont :: Maybe Font
envFont = Maybe Font
f}

findBlip :: Element -> Maybe Element
findBlip :: Element -> Maybe Element
findBlip Element
el = do
  Element
blip <- QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"blip" (forall a. a -> Maybe a
Just Text
a_ns) (forall a. a -> Maybe a
Just Text
"a")) Element
el
  -- return svg if present:
  (QName -> Bool) -> Element -> Maybe Element
filterElementName (\(QName Text
tag Maybe Text
_ Maybe Text
_) -> Text
tag forall a. Eq a => a -> a -> Bool
== Text
"svgBlip") Element
el forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
blip
 where
  a_ns :: Text
a_ns = Text
"http://schemas.openxmlformats.org/drawingml/2006/main"