{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
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.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,
filterChildrenName,
filterElementName,
parseXMLElement,
elChildren,
QName(QName, qName),
Content(Elem),
Element(elContent, elName),
findElements )
data ReaderEnv = ReaderEnv { ReaderEnv -> Notes
envNotes :: Notes
, :: 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 -> FilePath
envDocXmlPath :: FilePath
}
deriving Int -> ReaderEnv -> ShowS
[ReaderEnv] -> ShowS
ReaderEnv -> FilePath
(Int -> ReaderEnv -> ShowS)
-> (ReaderEnv -> FilePath)
-> ([ReaderEnv] -> ShowS)
-> Show ReaderEnv
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ReaderEnv] -> ShowS
$cshowList :: [ReaderEnv] -> ShowS
show :: ReaderEnv -> FilePath
$cshow :: ReaderEnv -> FilePath
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 -> FilePath
(Int -> ReaderState -> ShowS)
-> (ReaderState -> FilePath)
-> ([ReaderState] -> ShowS)
-> Show ReaderState
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ReaderState] -> ShowS
$cshowList :: [ReaderState] -> ShowS
show :: ReaderState -> FilePath
$cshow :: ReaderState -> FilePath
showsPrec :: Int -> ReaderState -> ShowS
$cshowsPrec :: Int -> ReaderState -> ShowS
Show
data FldCharState = FldCharOpen
| FldCharFieldInfo FieldInfo
| FldCharContent FieldInfo [ParPart]
deriving (Int -> FldCharState -> ShowS
[FldCharState] -> ShowS
FldCharState -> FilePath
(Int -> FldCharState -> ShowS)
-> (FldCharState -> FilePath)
-> ([FldCharState] -> ShowS)
-> Show FldCharState
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [FldCharState] -> ShowS
$cshowList :: [FldCharState] -> ShowS
show :: FldCharState -> FilePath
$cshow :: FldCharState -> FilePath
showsPrec :: Int -> FldCharState -> ShowS
$cshowsPrec :: Int -> FldCharState -> ShowS
Show)
data DocxError = DocxError
| WrongElem
deriving Int -> DocxError -> ShowS
[DocxError] -> ShowS
DocxError -> FilePath
(Int -> DocxError -> ShowS)
-> (DocxError -> FilePath)
-> ([DocxError] -> ShowS)
-> Show DocxError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [DocxError] -> ShowS
$cshowList :: [DocxError] -> ShowS
show :: DocxError -> FilePath
$cshow :: DocxError -> FilePath
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 :: D a
-> ReaderEnv -> ReaderState -> (Either DocxError a, ReaderState)
runD dx :: D a
dx re :: ReaderEnv
re rs :: ReaderState
rs = State ReaderState (Either DocxError a)
-> ReaderState -> (Either DocxError a, ReaderState)
forall s a. State s a -> s -> (a, s)
runState (ReaderT ReaderEnv (State ReaderState) (Either DocxError a)
-> ReaderEnv -> State ReaderState (Either DocxError a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (D a -> ReaderT ReaderEnv (State ReaderState) (Either DocxError a)
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 :: Maybe a -> D a
maybeToD (Just a :: a
a) = a -> D a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
maybeToD Nothing = DocxError -> D a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
DocxError
eitherToD :: Either a b -> D b
eitherToD :: Either a b -> D b
eitherToD (Right b :: b
b) = b -> D b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
eitherToD (Left _) = DocxError -> D b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
DocxError
concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
concatMapM :: (a -> m [b]) -> [a] -> m [b]
concatMapM f :: a -> m [b]
f xs :: [a]
xs = ([[b]] -> [b]) -> m [[b]] -> m [b]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[b]] -> [b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((a -> m [b]) -> [a] -> m [[b]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m [b]
f [a]
xs)
mapD :: (a -> D b) -> [a] -> D [b]
mapD :: (a -> D b) -> [a] -> D [b]
mapD f :: a -> D b
f xs :: [a]
xs =
let handler :: a -> D [b]
handler x :: a
x = (a -> D b
f a
x D b -> (b -> D [b]) -> D [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\y :: b
y-> [b] -> D [b]
forall (m :: * -> *) a. Monad m => a -> m a
return [b
y])) D [b] -> (DocxError -> D [b]) -> D [b]
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (\_ -> [b] -> D [b]
forall (m :: * -> *) a. Monad m => a -> m a
return [])
in
(a -> D [b]) -> [a] -> D [b]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM a -> D [b]
handler [a]
xs
unwrapElement :: NameSpaces -> Element -> [Element]
unwrapElement :: NameSpaces -> Element -> [Element]
unwrapElement ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "sdt" Element
element
, Just sdtContent :: Element
sdtContent <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "sdtContent" Element
element
= (Element -> [Element]) -> [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 "w" "smartTag" Element
element
= (Element -> [Element]) -> [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 = (Content -> [Content]) -> [Content] -> [Content]
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 ns :: NameSpaces
ns (Elem element :: Element
element) = (Element -> Content) -> [Element] -> [Content]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Content
Elem ([Element] -> [Content]) -> [Element] -> [Content]
forall a b. (a -> b) -> a -> b
$ NameSpaces -> Element -> [Element]
unwrapElement NameSpaces
ns Element
element
unwrapContent _ content :: Content
content = [Content
content]
walkDocument :: NameSpaces -> Element -> Element
walkDocument :: NameSpaces -> Element -> Element
walkDocument ns :: NameSpaces
ns element :: Element
element =
Element
element{ elContent :: [Content]
elContent = (Content -> [Content]) -> [Content] -> [Content]
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 -> FilePath
(Int -> Docx -> ShowS)
-> (Docx -> FilePath) -> ([Docx] -> ShowS) -> Show Docx
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Docx] -> ShowS
$cshowList :: [Docx] -> ShowS
show :: Docx -> FilePath
$cshow :: Docx -> FilePath
showsPrec :: Int -> Docx -> ShowS
$cshowsPrec :: Int -> Docx -> ShowS
Show
data Document = Document NameSpaces Body
deriving Int -> Document -> ShowS
[Document] -> ShowS
Document -> FilePath
(Int -> Document -> ShowS)
-> (Document -> FilePath) -> ([Document] -> ShowS) -> Show Document
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Document] -> ShowS
$cshowList :: [Document] -> ShowS
show :: Document -> FilePath
$cshow :: Document -> FilePath
showsPrec :: Int -> Document -> ShowS
$cshowsPrec :: Int -> Document -> ShowS
Show
newtype Body = Body [BodyPart]
deriving Int -> Body -> ShowS
[Body] -> ShowS
Body -> FilePath
(Int -> Body -> ShowS)
-> (Body -> FilePath) -> ([Body] -> ShowS) -> Show Body
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Body] -> ShowS
$cshowList :: [Body] -> ShowS
show :: Body -> FilePath
$cshow :: Body -> FilePath
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 -> FilePath
(Int -> Numbering -> ShowS)
-> (Numbering -> FilePath)
-> ([Numbering] -> ShowS)
-> Show Numbering
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Numbering] -> ShowS
$cshowList :: [Numbering] -> ShowS
show :: Numbering -> FilePath
$cshow :: Numbering -> FilePath
showsPrec :: Int -> Numbering -> ShowS
$cshowsPrec :: Int -> Numbering -> ShowS
Show
data Numb = Numb T.Text T.Text [LevelOverride]
deriving Int -> Numb -> ShowS
[Numb] -> ShowS
Numb -> FilePath
(Int -> Numb -> ShowS)
-> (Numb -> FilePath) -> ([Numb] -> ShowS) -> Show Numb
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Numb] -> ShowS
$cshowList :: [Numb] -> ShowS
show :: Numb -> FilePath
$cshow :: Numb -> FilePath
showsPrec :: Int -> Numb -> ShowS
$cshowsPrec :: Int -> Numb -> ShowS
Show
data LevelOverride = LevelOverride T.Text (Maybe Integer) (Maybe Level)
deriving Int -> LevelOverride -> ShowS
[LevelOverride] -> ShowS
LevelOverride -> FilePath
(Int -> LevelOverride -> ShowS)
-> (LevelOverride -> FilePath)
-> ([LevelOverride] -> ShowS)
-> Show LevelOverride
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [LevelOverride] -> ShowS
$cshowList :: [LevelOverride] -> ShowS
show :: LevelOverride -> FilePath
$cshow :: LevelOverride -> FilePath
showsPrec :: Int -> LevelOverride -> ShowS
$cshowsPrec :: Int -> LevelOverride -> ShowS
Show
data AbstractNumb = AbstractNumb T.Text [Level]
deriving Int -> AbstractNumb -> ShowS
[AbstractNumb] -> ShowS
AbstractNumb -> FilePath
(Int -> AbstractNumb -> ShowS)
-> (AbstractNumb -> FilePath)
-> ([AbstractNumb] -> ShowS)
-> Show AbstractNumb
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [AbstractNumb] -> ShowS
$cshowList :: [AbstractNumb] -> ShowS
show :: AbstractNumb -> FilePath
$cshow :: AbstractNumb -> FilePath
showsPrec :: Int -> AbstractNumb -> ShowS
$cshowsPrec :: Int -> AbstractNumb -> ShowS
Show
data Level = Level T.Text T.Text T.Text (Maybe Integer)
deriving Int -> Level -> ShowS
[Level] -> ShowS
Level -> FilePath
(Int -> Level -> ShowS)
-> (Level -> FilePath) -> ([Level] -> ShowS) -> Show Level
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Level] -> ShowS
$cshowList :: [Level] -> ShowS
show :: Level -> FilePath
$cshow :: Level -> FilePath
showsPrec :: Int -> Level -> ShowS
$cshowsPrec :: Int -> Level -> ShowS
Show
data DocumentLocation = InDocument | | InEndnote
deriving (DocumentLocation -> DocumentLocation -> Bool
(DocumentLocation -> DocumentLocation -> Bool)
-> (DocumentLocation -> DocumentLocation -> Bool)
-> Eq DocumentLocation
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 -> FilePath
(Int -> DocumentLocation -> ShowS)
-> (DocumentLocation -> FilePath)
-> ([DocumentLocation] -> ShowS)
-> Show DocumentLocation
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [DocumentLocation] -> ShowS
$cshowList :: [DocumentLocation] -> ShowS
show :: DocumentLocation -> FilePath
$cshow :: DocumentLocation -> FilePath
showsPrec :: Int -> DocumentLocation -> ShowS
$cshowsPrec :: Int -> DocumentLocation -> ShowS
Show)
data Relationship = Relationship DocumentLocation RelId Target
deriving Int -> Relationship -> ShowS
[Relationship] -> ShowS
Relationship -> FilePath
(Int -> Relationship -> ShowS)
-> (Relationship -> FilePath)
-> ([Relationship] -> ShowS)
-> Show Relationship
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Relationship] -> ShowS
$cshowList :: [Relationship] -> ShowS
show :: Relationship -> FilePath
$cshow :: Relationship -> FilePath
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 -> FilePath
(Int -> Notes -> ShowS)
-> (Notes -> FilePath) -> ([Notes] -> ShowS) -> Show Notes
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Notes] -> ShowS
$cshowList :: [Notes] -> ShowS
show :: Notes -> FilePath
$cshow :: Notes -> FilePath
showsPrec :: Int -> Notes -> ShowS
$cshowsPrec :: Int -> Notes -> ShowS
Show
data = NameSpaces (M.Map T.Text Element)
deriving Int -> Comments -> ShowS
[Comments] -> ShowS
Comments -> FilePath
(Int -> Comments -> ShowS)
-> (Comments -> FilePath) -> ([Comments] -> ShowS) -> Show Comments
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Comments] -> ShowS
$cshowList :: [Comments] -> ShowS
show :: Comments -> FilePath
$cshow :: Comments -> FilePath
showsPrec :: Int -> Comments -> ShowS
$cshowsPrec :: Int -> Comments -> ShowS
Show
data ChangeType = Insertion | Deletion
deriving Int -> ChangeType -> ShowS
[ChangeType] -> ShowS
ChangeType -> FilePath
(Int -> ChangeType -> ShowS)
-> (ChangeType -> FilePath)
-> ([ChangeType] -> ShowS)
-> Show ChangeType
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ChangeType] -> ShowS
$cshowList :: [ChangeType] -> ShowS
show :: ChangeType -> FilePath
$cshow :: ChangeType -> FilePath
showsPrec :: Int -> ChangeType -> ShowS
$cshowsPrec :: Int -> ChangeType -> ShowS
Show
data ChangeInfo = ChangeInfo ChangeId Author (Maybe ChangeDate)
deriving Int -> ChangeInfo -> ShowS
[ChangeInfo] -> ShowS
ChangeInfo -> FilePath
(Int -> ChangeInfo -> ShowS)
-> (ChangeInfo -> FilePath)
-> ([ChangeInfo] -> ShowS)
-> Show ChangeInfo
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ChangeInfo] -> ShowS
$cshowList :: [ChangeInfo] -> ShowS
show :: ChangeInfo -> FilePath
$cshow :: ChangeInfo -> FilePath
showsPrec :: Int -> ChangeInfo -> ShowS
$cshowsPrec :: Int -> ChangeInfo -> ShowS
Show
data TrackedChange = TrackedChange ChangeType ChangeInfo
deriving Int -> TrackedChange -> ShowS
[TrackedChange] -> ShowS
TrackedChange -> FilePath
(Int -> TrackedChange -> ShowS)
-> (TrackedChange -> FilePath)
-> ([TrackedChange] -> ShowS)
-> Show TrackedChange
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TrackedChange] -> ShowS
$cshowList :: [TrackedChange] -> ShowS
show :: TrackedChange -> FilePath
$cshow :: TrackedChange -> FilePath
showsPrec :: Int -> TrackedChange -> ShowS
$cshowsPrec :: Int -> TrackedChange -> ShowS
Show
data ParagraphStyle = ParagraphStyle { ParagraphStyle -> [ParStyle]
pStyle :: [ParStyle]
, ParagraphStyle -> Maybe ParIndentation
indentation :: Maybe ParIndentation
, ParagraphStyle -> Bool
dropCap :: Bool
, ParagraphStyle -> Maybe TrackedChange
pChange :: Maybe TrackedChange
, ParagraphStyle -> Maybe Bool
pBidi :: Maybe Bool
}
deriving Int -> ParagraphStyle -> ShowS
[ParagraphStyle] -> ShowS
ParagraphStyle -> FilePath
(Int -> ParagraphStyle -> ShowS)
-> (ParagraphStyle -> FilePath)
-> ([ParagraphStyle] -> ShowS)
-> Show ParagraphStyle
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ParagraphStyle] -> ShowS
$cshowList :: [ParagraphStyle] -> ShowS
show :: ParagraphStyle -> FilePath
$cshow :: ParagraphStyle -> FilePath
showsPrec :: Int -> ParagraphStyle -> ShowS
$cshowsPrec :: Int -> ParagraphStyle -> ShowS
Show
defaultParagraphStyle :: ParagraphStyle
defaultParagraphStyle :: ParagraphStyle
defaultParagraphStyle = ParagraphStyle :: [ParStyle]
-> Maybe ParIndentation
-> Bool
-> Maybe TrackedChange
-> Maybe Bool
-> ParagraphStyle
ParagraphStyle { pStyle :: [ParStyle]
pStyle = []
, indentation :: Maybe ParIndentation
indentation = Maybe ParIndentation
forall a. Maybe a
Nothing
, dropCap :: Bool
dropCap = Bool
False
, pChange :: Maybe TrackedChange
pChange = Maybe TrackedChange
forall a. Maybe a
Nothing
, pBidi :: Maybe Bool
pBidi = Bool -> Maybe Bool
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]
| OMathPara [Exp]
deriving Int -> BodyPart -> ShowS
[BodyPart] -> ShowS
BodyPart -> FilePath
(Int -> BodyPart -> ShowS)
-> (BodyPart -> FilePath) -> ([BodyPart] -> ShowS) -> Show BodyPart
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [BodyPart] -> ShowS
$cshowList :: [BodyPart] -> ShowS
show :: BodyPart -> FilePath
$cshow :: BodyPart -> FilePath
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 -> FilePath
(Int -> TblLook -> ShowS)
-> (TblLook -> FilePath) -> ([TblLook] -> ShowS) -> Show TblLook
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TblLook] -> ShowS
$cshowList :: [TblLook] -> ShowS
show :: TblLook -> FilePath
$cshow :: TblLook -> FilePath
showsPrec :: Int -> TblLook -> ShowS
$cshowsPrec :: Int -> TblLook -> ShowS
Show
defaultTblLook :: TblLook
defaultTblLook :: TblLook
defaultTblLook = TblLook :: Bool -> TblLook
TblLook{firstRowFormatting :: Bool
firstRowFormatting = Bool
False}
data Row = Row TblHeader [Cell] deriving Int -> Row -> ShowS
[Row] -> ShowS
Row -> FilePath
(Int -> Row -> ShowS)
-> (Row -> FilePath) -> ([Row] -> ShowS) -> Show Row
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Row] -> ShowS
$cshowList :: [Row] -> ShowS
show :: Row -> FilePath
$cshow :: Row -> FilePath
showsPrec :: Int -> Row -> ShowS
$cshowsPrec :: Int -> Row -> ShowS
Show
data = | deriving (Int -> TblHeader -> ShowS
[TblHeader] -> ShowS
TblHeader -> FilePath
(Int -> TblHeader -> ShowS)
-> (TblHeader -> FilePath)
-> ([TblHeader] -> ShowS)
-> Show TblHeader
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TblHeader] -> ShowS
$cshowList :: [TblHeader] -> ShowS
show :: TblHeader -> FilePath
$cshow :: TblHeader -> FilePath
showsPrec :: Int -> TblHeader -> ShowS
$cshowsPrec :: Int -> TblHeader -> ShowS
Show, TblHeader -> TblHeader -> Bool
(TblHeader -> TblHeader -> Bool)
-> (TblHeader -> TblHeader -> Bool) -> Eq TblHeader
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 -> FilePath
(Int -> Cell -> ShowS)
-> (Cell -> FilePath) -> ([Cell] -> ShowS) -> Show Cell
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Cell] -> ShowS
$cshowList :: [Cell] -> ShowS
show :: Cell -> FilePath
$cshow :: Cell -> FilePath
showsPrec :: Int -> Cell -> ShowS
$cshowsPrec :: Int -> Cell -> ShowS
Show
type GridSpan = Integer
data VMerge = Continue
| Restart
deriving (Int -> VMerge -> ShowS
[VMerge] -> ShowS
VMerge -> FilePath
(Int -> VMerge -> ShowS)
-> (VMerge -> FilePath) -> ([VMerge] -> ShowS) -> Show VMerge
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [VMerge] -> ShowS
$cshowList :: [VMerge] -> ShowS
show :: VMerge -> FilePath
$cshow :: VMerge -> FilePath
showsPrec :: Int -> VMerge -> ShowS
$cshowsPrec :: Int -> VMerge -> ShowS
Show, VMerge -> VMerge -> Bool
(VMerge -> VMerge -> Bool)
-> (VMerge -> VMerge -> Bool) -> Eq VMerge
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 rows :: [Row]
rows = let
removeMergedCells :: [[(a, Cell)]] -> [[(a, Cell)]]
removeMergedCells = ([(a, Cell)] -> [(a, Cell)]) -> [[(a, Cell)]] -> [[(a, Cell)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((a, Cell) -> Bool) -> [(a, Cell)] -> [(a, Cell)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(_, Cell _ vmerge :: VMerge
vmerge _) -> VMerge
vmerge VMerge -> VMerge -> Bool
forall a. Eq a => a -> a -> Bool
== VMerge
Restart))
in [[(Int, Cell)]] -> [[(Int, Cell)]]
forall a. [[(a, Cell)]] -> [[(a, Cell)]]
removeMergedCells ((Row -> [[(Int, Cell)]] -> [[(Int, Cell)]])
-> [[(Int, Cell)]] -> [Row] -> [[(Int, Cell)]]
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 _ cells :: [Cell]
cells) acc :: [[(Int, Cell)]]
acc = let
spans :: [(Int, Cell)]
spans = [Cell] -> Maybe Integer -> Maybe [(Int, Cell)] -> [(Int, Cell)]
g [Cell]
cells Maybe Integer
forall a. Maybe a
Nothing ([[(Int, Cell)]] -> Maybe [(Int, Cell)]
forall a. [a] -> Maybe a
listToMaybe [[(Int, Cell)]]
acc)
in [(Int, Cell)]
spans [(Int, Cell)] -> [[(Int, Cell)]] -> [[(Int, Cell)]]
forall a. a -> [a] -> [a]
: [[(Int, Cell)]]
acc
g :: [Cell]
-> Maybe Integer
-> Maybe [(Int, Cell)]
-> [(Int, Cell)]
g :: [Cell] -> Maybe Integer -> Maybe [(Int, Cell)] -> [(Int, Cell)]
g cells :: [Cell]
cells _ Nothing = [Int] -> [Cell] -> [(Int, Cell)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [Int]
forall a. a -> [a]
repeat 1) [Cell]
cells
g cells :: [Cell]
cells columnsLeftBelow :: Maybe Integer
columnsLeftBelow (Just rowBelow :: [(Int, Cell)]
rowBelow) =
case [Cell]
cells of
[] -> []
thisCell :: Cell
thisCell@(Cell thisGridSpan :: Integer
thisGridSpan _ _) : restOfRow :: [Cell]
restOfRow -> case [(Int, Cell)]
rowBelow of
[] -> [Int] -> [Cell] -> [(Int, Cell)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [Int]
forall a. a -> [a]
repeat 1) [Cell]
cells
(spanSoFarBelow :: Int
spanSoFarBelow, Cell gridSpanBelow :: Integer
gridSpanBelow vmerge :: VMerge
vmerge _) : _ ->
let spanSoFar :: Int
spanSoFar = case VMerge
vmerge of
Restart -> 1
Continue -> 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
spanSoFarBelow
columnsToDrop :: Integer
columnsToDrop = Integer
thisGridSpan Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ (Integer
gridSpanBelow Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe Integer
gridSpanBelow Maybe Integer
columnsLeftBelow)
(newColumnsLeftBelow :: Integer
newColumnsLeftBelow, restOfRowBelow :: [(Int, Cell)]
restOfRowBelow) = Integer -> [(Int, Cell)] -> (Integer, [(Int, Cell)])
forall a. Integer -> [(a, Cell)] -> (Integer, [(a, Cell)])
dropColumns Integer
columnsToDrop [(Int, Cell)]
rowBelow
in (Int
spanSoFar, Cell
thisCell) (Int, Cell) -> [(Int, Cell)] -> [(Int, Cell)]
forall a. a -> [a] -> [a]
: [Cell] -> Maybe Integer -> Maybe [(Int, Cell)] -> [(Int, Cell)]
g [Cell]
restOfRow (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
newColumnsLeftBelow) ([(Int, Cell)] -> Maybe [(Int, Cell)]
forall a. a -> Maybe a
Just [(Int, Cell)]
restOfRowBelow)
dropColumns :: Integer -> [(a, Cell)] -> (Integer, [(a, Cell)])
dropColumns :: Integer -> [(a, Cell)] -> (Integer, [(a, Cell)])
dropColumns n :: Integer
n [] = (Integer
n, [])
dropColumns n :: Integer
n cells :: [(a, Cell)]
cells@((_, Cell gridSpan :: Integer
gridSpan _ _) : otherCells :: [(a, Cell)]
otherCells) =
if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
gridSpan
then (Integer
gridSpan Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
n, [(a, Cell)]
cells)
else Integer -> [(a, Cell)] -> (Integer, [(a, Cell)])
forall a. Integer -> [(a, Cell)] -> (Integer, [(a, Cell)])
dropColumns (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
gridSpan) [(a, Cell)]
otherCells
leftBiasedMergeRunStyle :: RunStyle -> RunStyle -> RunStyle
leftBiasedMergeRunStyle :: RunStyle -> RunStyle -> RunStyle
leftBiasedMergeRunStyle a :: RunStyle
a b :: RunStyle
b = RunStyle :: Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe VertAlign
-> Maybe Text
-> Maybe CharStyle
-> RunStyle
RunStyle
{ isBold :: Maybe Bool
isBold = RunStyle -> Maybe Bool
isBold RunStyle
a Maybe Bool -> Maybe Bool -> Maybe Bool
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 Maybe Bool -> Maybe Bool -> Maybe Bool
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 Maybe Bool -> Maybe Bool -> Maybe Bool
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 Maybe Bool -> Maybe Bool -> Maybe Bool
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 Maybe Bool -> Maybe Bool -> Maybe Bool
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 Maybe Bool -> Maybe Bool -> Maybe Bool
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 Maybe Bool -> Maybe Bool -> Maybe Bool
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 Maybe Bool -> Maybe Bool -> Maybe Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RunStyle -> Maybe Bool
isForceCTL RunStyle
b
, rVertAlign :: Maybe VertAlign
rVertAlign = RunStyle -> Maybe VertAlign
rVertAlign RunStyle
a Maybe VertAlign -> Maybe VertAlign -> Maybe VertAlign
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 Maybe Text -> Maybe Text -> Maybe Text
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
}
type Extent = Maybe (Double, Double)
data ParPart = PlainRun Run
| ChangedRuns TrackedChange [Run]
| CommentId Author (Maybe CommentDate) [BodyPart]
| CommentId
| BookMark BookMarkId Anchor
| InternalHyperLink Anchor [ParPart]
| ExternalHyperLink URL [ParPart]
| Drawing FilePath T.Text T.Text B.ByteString Extent
| Chart
| Diagram
| PlainOMath [Exp]
| Field FieldInfo [ParPart]
deriving Int -> ParPart -> ShowS
[ParPart] -> ShowS
ParPart -> FilePath
(Int -> ParPart -> ShowS)
-> (ParPart -> FilePath) -> ([ParPart] -> ShowS) -> Show ParPart
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ParPart] -> ShowS
$cshowList :: [ParPart] -> ShowS
show :: ParPart -> FilePath
$cshow :: ParPart -> FilePath
showsPrec :: Int -> ParPart -> ShowS
$cshowsPrec :: Int -> ParPart -> ShowS
Show
data Run = Run RunStyle [RunElem]
| [BodyPart]
| Endnote [BodyPart]
| InlineDrawing FilePath T.Text T.Text B.ByteString Extent
| InlineChart
| InlineDiagram
deriving Int -> Run -> ShowS
[Run] -> ShowS
Run -> FilePath
(Int -> Run -> ShowS)
-> (Run -> FilePath) -> ([Run] -> ShowS) -> Show Run
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Run] -> ShowS
$cshowList :: [Run] -> ShowS
show :: Run -> FilePath
$cshow :: Run -> FilePath
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 -> FilePath
(Int -> RunElem -> ShowS)
-> (RunElem -> FilePath) -> ([RunElem] -> ShowS) -> Show RunElem
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [RunElem] -> ShowS
$cshowList :: [RunElem] -> ShowS
show :: RunElem -> FilePath
$cshow :: RunElem -> FilePath
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 = T.Text
type Author = T.Text
type ChangeDate = T.Text
type = T.Text
archiveToDocx :: Archive -> Either DocxError Docx
archiveToDocx :: Archive -> Either DocxError Docx
archiveToDocx archive :: Archive
archive = (Docx, [Text]) -> Docx
forall a b. (a, b) -> a
fst ((Docx, [Text]) -> Docx)
-> Either DocxError (Docx, [Text]) -> Either DocxError Docx
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
archive = do
FilePath
docXmlPath <- case Archive -> Maybe FilePath
getDocumentXmlPath Archive
archive of
Just fp :: FilePath
fp -> FilePath -> Either DocxError FilePath
forall a b. b -> Either a b
Right FilePath
fp
Nothing -> DocxError -> Either DocxError FilePath
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 -> FilePath -> [Relationship]
archiveToRelationships Archive
archive FilePath
docXmlPath
media :: Media
media = Archive -> (FilePath -> Bool) -> Media
filteredFilesFromArchive Archive
archive FilePath -> Bool
filePathIsMedia
(styles :: CharStyleMap
styles, parstyles :: ParStyleMap
parstyles) = Archive -> (CharStyleMap, ParStyleMap)
archiveToStyles Archive
archive
rEnv :: ReaderEnv
rEnv = ReaderEnv :: Notes
-> Comments
-> Numbering
-> [Relationship]
-> Media
-> Maybe Font
-> CharStyleMap
-> ParStyleMap
-> DocumentLocation
-> FilePath
-> ReaderEnv
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 = Maybe Font
forall a. Maybe a
Nothing
, envCharStyles :: CharStyleMap
envCharStyles = CharStyleMap
styles
, envParStyles :: ParStyleMap
envParStyles = ParStyleMap
parstyles
, envLocation :: DocumentLocation
envLocation = DocumentLocation
InDocument
, envDocXmlPath :: FilePath
envDocXmlPath = FilePath
docXmlPath
}
rState :: ReaderState
rState = ReaderState :: [Text] -> [FldCharState] -> ReaderState
ReaderState { stateWarnings :: [Text]
stateWarnings = []
, stateFldCharState :: [FldCharState]
stateFldCharState = []
}
(eitherDoc :: Either DocxError Document
eitherDoc, st :: ReaderState
st) = D Document
-> ReaderEnv
-> ReaderState
-> (Either DocxError Document, ReaderState)
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 doc :: Document
doc -> (Docx, [Text]) -> Either DocxError (Docx, [Text])
forall a b. b -> Either a b
Right (Document -> Docx
Docx Document
doc, ReaderState -> [Text]
stateWarnings ReaderState
st)
Left e :: DocxError
e -> DocxError -> Either DocxError (Docx, [Text])
forall a b. a -> Either a b
Left DocxError
e
parseXMLFromEntry :: Entry -> Maybe Element
parseXMLFromEntry :: Entry -> Maybe Element
parseXMLFromEntry entry :: Entry
entry =
case Text -> Either Text Element
parseXMLElement (ByteString -> Text
UTF8.toTextLazy (Entry -> ByteString
fromEntry Entry
entry)) of
Left _ -> Maybe Element
forall a. Maybe a
Nothing
Right el :: Element
el -> Element -> Maybe Element
forall a. a -> Maybe a
Just Element
el
getDocumentXmlPath :: Archive -> Maybe FilePath
getDocumentXmlPath :: Archive -> Maybe FilePath
getDocumentXmlPath zf :: Archive
zf = do
Entry
entry <- FilePath -> Archive -> Maybe Entry
findEntryByPath "_rels/.rels" Archive
zf
Element
relsElem <- Entry -> Maybe Element
parseXMLFromEntry Entry
entry
let rels :: [Element]
rels = (QName -> Bool) -> Element -> [Element]
filterChildrenName (\n :: QName
n -> QName -> Text
qName QName
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Relationship") Element
relsElem
Element
rel <- (Element -> Bool) -> [Element] -> Maybe Element
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\e :: Element
e -> QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "Type" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
e Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
==
Text -> Maybe Text
forall a. a -> Maybe a
Just "http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument")
[Element]
rels
Text
fp <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "Target" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
rel
FilePath -> Maybe FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ case Text -> FilePath
T.unpack Text
fp of
'/' : fp' :: FilePath
fp' -> FilePath
fp'
fp' :: FilePath
fp' -> FilePath
fp'
archiveToDocument :: Archive -> D Document
archiveToDocument :: Archive -> D Document
archiveToDocument zf :: Archive
zf = do
FilePath
docPath <- (ReaderEnv -> FilePath)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) FilePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> FilePath
envDocXmlPath
Entry
entry <- Maybe Entry -> D Entry
forall a. Maybe a -> D a
maybeToD (Maybe Entry -> D Entry) -> Maybe Entry -> D Entry
forall a b. (a -> b) -> a -> b
$ FilePath -> Archive -> Maybe Entry
findEntryByPath FilePath
docPath Archive
zf
Element
docElem <- Maybe Element -> D Element
forall a. Maybe a -> D a
maybeToD (Maybe Element -> D Element) -> Maybe Element -> D Element
forall a b. (a -> b) -> a -> b
$ Entry -> Maybe Element
parseXMLFromEntry Entry
entry
let namespaces :: NameSpaces
namespaces = Element -> NameSpaces
elemToNameSpaces Element
docElem
Element
bodyElem <- Maybe Element -> D Element
forall a. Maybe a -> D a
maybeToD (Maybe Element -> D Element) -> Maybe Element -> D Element
forall a b. (a -> b) -> a -> b
$ NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
namespaces "w" "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'
Document -> D Document
forall (m :: * -> *) a. Monad m => a -> m a
return (Document -> D Document) -> Document -> D Document
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 ns :: NameSpaces
ns element :: Element
element | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "body" Element
element =
([BodyPart] -> Body)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart]
-> D Body
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [BodyPart] -> Body
Body ((Element -> D BodyPart)
-> [Element]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart]
forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D BodyPart
elemToBodyPart NameSpaces
ns) (Element -> [Element]
elChildren Element
element))
elemToBody _ _ = DocxError -> D Body
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
archiveToStyles :: Archive -> (CharStyleMap, ParStyleMap)
archiveToStyles :: Archive -> (CharStyleMap, ParStyleMap)
archiveToStyles = (CharStyle -> CharStyleId)
-> (ParStyle -> ParaStyleId)
-> Archive
-> (CharStyleMap, ParStyleMap)
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' CharStyle -> CharStyleId
forall a. HasStyleId a => a -> StyleId a
getStyleId ParStyle -> ParaStyleId
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 (RunStyle -> Maybe CharStyle)
-> (CharStyle -> RunStyle) -> CharStyle -> Maybe CharStyle
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 :: t a -> t (StyleName a)
getStyleNames = (a -> StyleName a) -> t a -> t (StyleName a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> StyleName a
forall a. HasStyleName a => a -> StyleName a
getStyleName
constructBogusParStyleData :: ParaStyleName -> ParStyle
constructBogusParStyleData :: ParaStyleName -> ParStyle
constructBogusParStyleData stName :: ParaStyleName
stName = ParStyle :: Maybe (ParaStyleName, Int)
-> Maybe ParIndentation
-> Maybe (Text, Text)
-> Maybe ParStyle
-> ParaStyleName
-> ParaStyleId
-> ParStyle
ParStyle
{ headingLev :: Maybe (ParaStyleName, Int)
headingLev = Maybe (ParaStyleName, Int)
forall a. Maybe a
Nothing
, indent :: Maybe ParIndentation
indent = Maybe ParIndentation
forall a. Maybe a
Nothing
, numInfo :: Maybe (Text, Text)
numInfo = Maybe (Text, Text)
forall a. Maybe a
Nothing
, psParentStyle :: Maybe ParStyle
psParentStyle = Maybe ParStyle
forall a. Maybe a
Nothing
, pStyleName :: ParaStyleName
pStyleName = ParaStyleName
stName
, pStyleId :: ParaStyleId
pStyleId = Text -> ParaStyleId
ParaStyleId (Text -> ParaStyleId)
-> (ParaStyleName -> Text) -> ParaStyleName -> ParaStyleId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=' ') (Text -> Text) -> (ParaStyleName -> Text) -> ParaStyleName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParaStyleName -> Text
forall a. FromStyleName a => a -> Text
fromStyleName (ParaStyleName -> ParaStyleId) -> ParaStyleName -> ParaStyleId
forall a b. (a -> b) -> a -> b
$ ParaStyleName
stName
}
archiveToNotes :: Archive -> Notes
archiveToNotes :: Archive -> Notes
archiveToNotes zf :: Archive
zf =
let fnElem :: Maybe Element
fnElem = FilePath -> Archive -> Maybe Entry
findEntryByPath "word/footnotes.xml" Archive
zf
Maybe Entry -> (Entry -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Entry -> Maybe Element
parseXMLFromEntry
enElem :: Maybe Element
enElem = FilePath -> Archive -> Maybe Entry
findEntryByPath "word/endnotes.xml" Archive
zf
Maybe Entry -> (Entry -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Entry -> Maybe Element
parseXMLFromEntry
fn_namespaces :: NameSpaces
fn_namespaces = NameSpaces
-> (Element -> NameSpaces) -> Maybe Element -> NameSpaces
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NameSpaces
forall a. Monoid a => a
mempty Element -> NameSpaces
elemToNameSpaces Maybe Element
fnElem
en_namespaces :: NameSpaces
en_namespaces = NameSpaces
-> (Element -> NameSpaces) -> Maybe Element -> NameSpaces
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NameSpaces
forall a. Monoid a => a
mempty Element -> NameSpaces
elemToNameSpaces Maybe Element
enElem
ns :: NameSpaces
ns = NameSpaces -> NameSpaces -> NameSpaces
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 Maybe Element
-> (Element -> Maybe (Map Text Element))
-> Maybe (Map Text Element)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Element -> Maybe (Map Text Element)
elemToNotes NameSpaces
ns "footnote" (Element -> Maybe (Map Text Element))
-> (Element -> Element) -> Element -> Maybe (Map Text Element)
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 Maybe Element
-> (Element -> Maybe (Map Text Element))
-> Maybe (Map Text Element)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Element -> Maybe (Map Text Element)
elemToNotes NameSpaces
ns "endnote" (Element -> Maybe (Map Text Element))
-> (Element -> Element) -> Element -> Maybe (Map Text Element)
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
zf :: Archive
zf =
let cmtsElem :: Maybe Element
cmtsElem = FilePath -> Archive -> Maybe Entry
findEntryByPath "word/comments.xml" Archive
zf
Maybe Entry -> (Entry -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Entry -> Maybe Element
parseXMLFromEntry
cmts_namespaces :: NameSpaces
cmts_namespaces = NameSpaces
-> (Element -> NameSpaces) -> Maybe Element -> NameSpaces
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NameSpaces
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 (Element -> Map Text Element)
-> (Element -> Element) -> Element -> Map Text Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpaces -> Element -> Element
walkDocument NameSpaces
cmts_namespaces (Element -> Map Text Element)
-> Maybe Element -> Maybe (Map Text Element)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Maybe Element
cmtsElem
in
case Maybe (Map Text Element)
cmts of
Just c :: Map Text Element
c -> NameSpaces -> Map Text Element -> Comments
Comments NameSpaces
cmts_namespaces Map Text Element
c
Nothing -> NameSpaces -> Map Text Element -> Comments
Comments NameSpaces
cmts_namespaces Map Text Element
forall k a. Map k a
M.empty
filePathToRelType :: FilePath -> FilePath -> Maybe DocumentLocation
filePathToRelType :: FilePath -> FilePath -> Maybe DocumentLocation
filePathToRelType "word/_rels/footnotes.xml.rels" _ = DocumentLocation -> Maybe DocumentLocation
forall a. a -> Maybe a
Just DocumentLocation
InFootnote
filePathToRelType "word/_rels/endnotes.xml.rels" _ = DocumentLocation -> Maybe DocumentLocation
forall a. a -> Maybe a
Just DocumentLocation
InEndnote
filePathToRelType path :: FilePath
path docXmlPath :: FilePath
docXmlPath =
if FilePath
path FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "word/_rels/" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
takeFileName FilePath
docXmlPath FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ".rels"
then DocumentLocation -> Maybe DocumentLocation
forall a. a -> Maybe a
Just DocumentLocation
InDocument
else Maybe DocumentLocation
forall a. Maybe a
Nothing
relElemToRelationship :: FilePath -> DocumentLocation -> Element
-> Maybe Relationship
relElemToRelationship :: FilePath -> DocumentLocation -> Element -> Maybe Relationship
relElemToRelationship fp :: FilePath
fp relType :: DocumentLocation
relType element :: Element
element | QName -> Text
qName (Element -> QName
elName Element
element) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "Relationship" =
do
Text
relId <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "Id" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
element
Text
target <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName "Target" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
element
let frontOfFp :: Text
frontOfFp = FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '_') FilePath
fp
let target' :: Text
target' = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
target (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$
Text -> Text -> Maybe Text
T.stripPrefix Text
frontOfFp (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/') Text
target
Relationship -> Maybe Relationship
forall (m :: * -> *) a. Monad m => a -> m a
return (Relationship -> Maybe Relationship)
-> Relationship -> Maybe Relationship
forall a b. (a -> b) -> a -> b
$ DocumentLocation -> Text -> Text -> Relationship
Relationship DocumentLocation
relType Text
relId Text
target'
relElemToRelationship _ _ _ = Maybe Relationship
forall a. Maybe a
Nothing
filePathToRelationships :: Archive -> FilePath -> FilePath -> [Relationship]
filePathToRelationships :: Archive -> FilePath -> FilePath -> [Relationship]
filePathToRelationships ar :: Archive
ar docXmlPath :: FilePath
docXmlPath fp :: FilePath
fp
| Just relType :: DocumentLocation
relType <- FilePath -> FilePath -> Maybe DocumentLocation
filePathToRelType FilePath
fp FilePath
docXmlPath
, Just entry :: Entry
entry <- FilePath -> Archive -> Maybe Entry
findEntryByPath FilePath
fp Archive
ar
, Just relElems :: Element
relElems <- Entry -> Maybe Element
parseXMLFromEntry Entry
entry =
(Element -> Maybe Relationship) -> [Element] -> [Relationship]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (FilePath -> DocumentLocation -> Element -> Maybe Relationship
relElemToRelationship FilePath
fp DocumentLocation
relType) ([Element] -> [Relationship]) -> [Element] -> [Relationship]
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
elChildren Element
relElems
filePathToRelationships _ _ _ = []
archiveToRelationships :: Archive -> FilePath -> [Relationship]
archiveToRelationships :: Archive -> FilePath -> [Relationship]
archiveToRelationships archive :: Archive
archive docXmlPath :: FilePath
docXmlPath =
(FilePath -> [Relationship]) -> [FilePath] -> [Relationship]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Archive -> FilePath -> FilePath -> [Relationship]
filePathToRelationships Archive
archive FilePath
docXmlPath) ([FilePath] -> [Relationship]) -> [FilePath] -> [Relationship]
forall a b. (a -> b) -> a -> b
$ Archive -> [FilePath]
filesInArchive Archive
archive
filePathIsMedia :: FilePath -> Bool
filePathIsMedia :: FilePath -> Bool
filePathIsMedia fp :: FilePath
fp =
"media" FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath -> [FilePath]
splitDirectories (ShowS
takeDirectory FilePath
fp)
lookupLevel :: T.Text -> T.Text -> Numbering -> Maybe Level
lookupLevel :: Text -> Text -> Numbering -> Maybe Level
lookupLevel numId :: Text
numId ilvl :: Text
ilvl (Numbering _ numbs :: [Numb]
numbs absNumbs :: [AbstractNumb]
absNumbs) = do
(absNumId :: Text
absNumId, ovrrides :: [LevelOverride]
ovrrides) <- Text
-> [(Text, (Text, [LevelOverride]))]
-> Maybe (Text, [LevelOverride])
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
numId ([(Text, (Text, [LevelOverride]))]
-> Maybe (Text, [LevelOverride]))
-> [(Text, (Text, [LevelOverride]))]
-> Maybe (Text, [LevelOverride])
forall a b. (a -> b) -> a -> b
$
(Numb -> (Text, (Text, [LevelOverride])))
-> [Numb] -> [(Text, (Text, [LevelOverride]))]
forall a b. (a -> b) -> [a] -> [b]
map (\(Numb nid :: Text
nid absnumid :: Text
absnumid ovrRides :: [LevelOverride]
ovrRides) -> (Text
nid, (Text
absnumid, [LevelOverride]
ovrRides))) [Numb]
numbs
[Level]
lvls <- Text -> [(Text, [Level])] -> Maybe [Level]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
absNumId ([(Text, [Level])] -> Maybe [Level])
-> [(Text, [Level])] -> Maybe [Level]
forall a b. (a -> b) -> a -> b
$
(AbstractNumb -> (Text, [Level]))
-> [AbstractNumb] -> [(Text, [Level])]
forall a b. (a -> b) -> [a] -> [b]
map (\(AbstractNumb aid :: Text
aid ls :: [Level]
ls) -> (Text
aid, [Level]
ls)) [AbstractNumb]
absNumbs
let lvlOverride :: Maybe LevelOverride
lvlOverride = Text -> [(Text, LevelOverride)] -> Maybe LevelOverride
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
ilvl ([(Text, LevelOverride)] -> Maybe LevelOverride)
-> [(Text, LevelOverride)] -> Maybe LevelOverride
forall a b. (a -> b) -> a -> b
$
(LevelOverride -> (Text, LevelOverride))
-> [LevelOverride] -> [(Text, LevelOverride)]
forall a b. (a -> b) -> [a] -> [b]
map (\lo :: LevelOverride
lo@(LevelOverride ilvl' :: Text
ilvl' _ _) -> (Text
ilvl', LevelOverride
lo)) [LevelOverride]
ovrrides
case Maybe LevelOverride
lvlOverride of
Just (LevelOverride _ _ (Just lvl' :: Level
lvl')) -> Level -> Maybe Level
forall a. a -> Maybe a
Just Level
lvl'
Just (LevelOverride _ (Just strt :: Integer
strt) _) ->
Text -> [(Text, Level)] -> Maybe Level
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
ilvl ([(Text, Level)] -> Maybe Level) -> [(Text, Level)] -> Maybe Level
forall a b. (a -> b) -> a -> b
$ (Level -> (Text, Level)) -> [Level] -> [(Text, Level)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Level i :: Text
i fmt :: Text
fmt s :: Text
s _) -> (Text
i, Text -> Text -> Text -> Maybe Integer -> Level
Level Text
i Text
fmt Text
s (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
strt))) [Level]
lvls
_ ->
Text -> [(Text, Level)] -> Maybe Level
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
ilvl ([(Text, Level)] -> Maybe Level) -> [(Text, Level)] -> Maybe Level
forall a b. (a -> b) -> a -> b
$ (Level -> (Text, Level)) -> [Level] -> [(Text, Level)]
forall a b. (a -> b) -> [a] -> [b]
map (\l :: Level
l@(Level i :: Text
i _ _ _) -> (Text
i, Level
l)) [Level]
lvls
loElemToLevelOverride :: NameSpaces -> Element -> Maybe LevelOverride
loElemToLevelOverride :: NameSpaces -> Element -> Maybe LevelOverride
loElemToLevelOverride ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "lvlOverride" Element
element = do
Text
ilvl <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "ilvl" Element
element
let startOverride :: Maybe Integer
startOverride = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "startOverride" Element
element
Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "val"
Maybe Text -> (Text -> Maybe Integer) -> Maybe Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Integer
stringToInteger
lvl :: Maybe Level
lvl = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "lvl" Element
element
Maybe Element -> (Element -> Maybe Level) -> Maybe Level
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Element -> Maybe Level
levelElemToLevel NameSpaces
ns
LevelOverride -> Maybe LevelOverride
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelOverride -> Maybe LevelOverride)
-> LevelOverride -> Maybe LevelOverride
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Integer -> Maybe Level -> LevelOverride
LevelOverride Text
ilvl Maybe Integer
startOverride Maybe Level
lvl
loElemToLevelOverride _ _ = Maybe LevelOverride
forall a. Maybe a
Nothing
numElemToNum :: NameSpaces -> Element -> Maybe Numb
numElemToNum :: NameSpaces -> Element -> Maybe Numb
numElemToNum ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "num" Element
element = do
Text
numId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "numId" Element
element
Text
absNumId <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "abstractNumId" Element
element
Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "val"
let lvlOverrides :: [LevelOverride]
lvlOverrides = (Element -> Maybe LevelOverride) -> [Element] -> [LevelOverride]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
(NameSpaces -> Element -> Maybe LevelOverride
loElemToLevelOverride NameSpaces
ns)
(NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns "w" "lvlOverride" Element
element)
Numb -> Maybe Numb
forall (m :: * -> *) a. Monad m => a -> m a
return (Numb -> Maybe Numb) -> Numb -> Maybe Numb
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [LevelOverride] -> Numb
Numb Text
numId Text
absNumId [LevelOverride]
lvlOverrides
numElemToNum _ _ = Maybe Numb
forall a. Maybe a
Nothing
absNumElemToAbsNum :: NameSpaces -> Element -> Maybe AbstractNumb
absNumElemToAbsNum :: NameSpaces -> Element -> Maybe AbstractNumb
absNumElemToAbsNum ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "abstractNum" Element
element = do
Text
absNumId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "abstractNumId" Element
element
let levelElems :: [Element]
levelElems = NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns "w" "lvl" Element
element
levels :: [Level]
levels = (Element -> Maybe Level) -> [Element] -> [Level]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NameSpaces -> Element -> Maybe Level
levelElemToLevel NameSpaces
ns) [Element]
levelElems
AbstractNumb -> Maybe AbstractNumb
forall (m :: * -> *) a. Monad m => a -> m a
return (AbstractNumb -> Maybe AbstractNumb)
-> AbstractNumb -> Maybe AbstractNumb
forall a b. (a -> b) -> a -> b
$ Text -> [Level] -> AbstractNumb
AbstractNumb Text
absNumId [Level]
levels
absNumElemToAbsNum _ _ = Maybe AbstractNumb
forall a. Maybe a
Nothing
levelElemToLevel :: NameSpaces -> Element -> Maybe Level
levelElemToLevel :: NameSpaces -> Element -> Maybe Level
levelElemToLevel ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "lvl" Element
element = do
Text
ilvl <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "ilvl" Element
element
Text
fmt <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "numFmt" Element
element
Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "val"
Text
txt <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "lvlText" Element
element
Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "val"
let start :: Maybe Integer
start = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "start" Element
element
Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "val"
Maybe Text -> (Text -> Maybe Integer) -> Maybe Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Integer
stringToInteger
Level -> Maybe Level
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text -> Text -> Maybe Integer -> Level
Level Text
ilvl Text
fmt Text
txt Maybe Integer
start)
levelElemToLevel _ _ = Maybe Level
forall a. Maybe a
Nothing
archiveToNumbering' :: Archive -> Maybe Numbering
archiveToNumbering' :: Archive -> Maybe Numbering
archiveToNumbering' zf :: Archive
zf =
case FilePath -> Archive -> Maybe Entry
findEntryByPath "word/numbering.xml" Archive
zf of
Nothing -> Numbering -> Maybe Numbering
forall a. a -> Maybe a
Just (Numbering -> Maybe Numbering) -> Numbering -> Maybe Numbering
forall a b. (a -> b) -> a -> b
$ NameSpaces -> [Numb] -> [AbstractNumb] -> Numbering
Numbering NameSpaces
forall a. Monoid a => a
mempty [] []
Just entry :: 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 "w" "num" Element
numberingElem
absNumElems :: [Element]
absNumElems = NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
namespaces "w" "abstractNum" Element
numberingElem
nums :: [Numb]
nums = (Element -> Maybe Numb) -> [Element] -> [Numb]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NameSpaces -> Element -> Maybe Numb
numElemToNum NameSpaces
namespaces) [Element]
numElems
absNums :: [AbstractNumb]
absNums = (Element -> Maybe AbstractNumb) -> [Element] -> [AbstractNumb]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NameSpaces -> Element -> Maybe AbstractNumb
absNumElemToAbsNum NameSpaces
namespaces) [Element]
absNumElems
Numbering -> Maybe Numbering
forall (m :: * -> *) a. Monad m => a -> m a
return (Numbering -> Maybe Numbering) -> Numbering -> Maybe Numbering
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
archive =
Numbering -> Maybe Numbering -> Numbering
forall a. a -> Maybe a -> a
fromMaybe (NameSpaces -> [Numb] -> [AbstractNumb] -> Numbering
Numbering NameSpaces
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 ns :: NameSpaces
ns notetype :: Text
notetype element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" (Text
notetype Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "s") Element
element =
let pairs :: [(Text, Element)]
pairs = (Element -> Maybe (Text, Element))
-> [Element] -> [(Text, Element)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
(\e :: Element
e -> NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "id" Element
e Maybe Text
-> (Text -> Maybe (Text, Element)) -> Maybe (Text, Element)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(\a :: Text
a -> (Text, Element) -> Maybe (Text, Element)
forall a. a -> Maybe a
Just (Text
a, Element
e)))
(NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns "w" Text
notetype Element
element)
in
Map Text Element -> Maybe (Map Text Element)
forall a. a -> Maybe a
Just (Map Text Element -> Maybe (Map Text Element))
-> Map Text Element -> Maybe (Map Text Element)
forall a b. (a -> b) -> a -> b
$
[(Text, Element)] -> Map Text Element
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text, Element)]
pairs
elemToNotes _ _ _ = Maybe (Map Text Element)
forall a. Maybe a
Nothing
elemToComments :: NameSpaces -> Element -> M.Map T.Text Element
ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "comments" Element
element =
let pairs :: [(Text, Element)]
pairs = (Element -> Maybe (Text, Element))
-> [Element] -> [(Text, Element)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
(\e :: Element
e -> NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "id" Element
e Maybe Text
-> (Text -> Maybe (Text, Element)) -> Maybe (Text, Element)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(\a :: Text
a -> (Text, Element) -> Maybe (Text, Element)
forall a. a -> Maybe a
Just (Text
a, Element
e)))
(NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns "w" "comment" Element
element)
in
[(Text, Element)] -> Map Text Element
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text, Element)]
pairs
elemToComments _ _ = Map Text Element
forall k a. Map k a
M.empty
elemToTblGrid :: NameSpaces -> Element -> D TblGrid
elemToTblGrid :: NameSpaces -> Element -> D TblGrid
elemToTblGrid ns :: NameSpaces
ns element :: Element
element | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "tblGrid" Element
element =
let cols :: [Element]
cols = NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns "w" "gridCol" Element
element
in
(Element -> D Integer) -> [Element] -> D TblGrid
forall a b. (a -> D b) -> [a] -> D [b]
mapD (\e :: Element
e -> Maybe Integer -> D Integer
forall a. Maybe a -> D a
maybeToD (NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "w" Element
e Maybe Text -> (Text -> Maybe Integer) -> Maybe Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Integer
stringToInteger))
[Element]
cols
elemToTblGrid _ _ = DocxError -> D TblGrid
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
elemToTblLook :: NameSpaces -> Element -> D TblLook
elemToTblLook :: NameSpaces -> Element -> D TblLook
elemToTblLook ns :: NameSpaces
ns element :: Element
element | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "tblLook" Element
element =
let firstRow :: Maybe Text
firstRow = NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "firstRow" Element
element
val :: Maybe Text
val = NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "val" Element
element
firstRowFmt :: Bool
firstRowFmt =
case Maybe Text
firstRow of
Just "1" -> Bool
True
Just _ -> Bool
False
Nothing -> case Maybe Text
val of
Just bitMask :: Text
bitMask -> Text -> Int -> Bool
testBitMask Text
bitMask 0x020
Nothing -> Bool
False
in
TblLook -> D TblLook
forall (m :: * -> *) a. Monad m => a -> m a
return TblLook :: Bool -> TblLook
TblLook{firstRowFormatting :: Bool
firstRowFormatting = Bool
firstRowFmt}
elemToTblLook _ _ = DocxError -> D TblLook
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
elemToRow :: NameSpaces -> Element -> D Row
elemToRow :: NameSpaces -> Element -> D Row
elemToRow ns :: NameSpaces
ns element :: Element
element | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "tr" Element
element =
do
let cellElems :: [Element]
cellElems = NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns "w" "tc" Element
element
[Cell]
cells <- (Element -> D Cell) -> [Element] -> D [Cell]
forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D Cell
elemToCell NameSpaces
ns) [Element]
cellElems
let hasTblHeader :: TblHeader
hasTblHeader = TblHeader -> (Element -> TblHeader) -> Maybe Element -> TblHeader
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TblHeader
NoTblHeader (TblHeader -> Element -> TblHeader
forall a b. a -> b -> a
const TblHeader
HasTblHeader)
(NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "trPr" Element
element
Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "tblHeader")
Row -> D Row
forall (m :: * -> *) a. Monad m => a -> m a
return (Row -> D Row) -> Row -> D Row
forall a b. (a -> b) -> a -> b
$ TblHeader -> [Cell] -> Row
Row TblHeader
hasTblHeader [Cell]
cells
elemToRow _ _ = DocxError -> D Row
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
elemToCell :: NameSpaces -> Element -> D Cell
elemToCell :: NameSpaces -> Element -> D Cell
elemToCell ns :: NameSpaces
ns element :: Element
element | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "tc" Element
element =
do
let properties :: Maybe Element
properties = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "tcPr" Element
element
let gridSpan :: Maybe Integer
gridSpan = Maybe Element
properties
Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "gridSpan"
Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "val"
Maybe Text -> (Text -> Maybe Integer) -> Maybe Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Integer
stringToInteger
let vMerge :: VMerge
vMerge = case Maybe Element
properties Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "vMerge" of
Nothing -> VMerge
Restart
Just e :: Element
e ->
VMerge -> Maybe VMerge -> VMerge
forall a. a -> Maybe a -> a
fromMaybe VMerge
Continue (Maybe VMerge -> VMerge) -> Maybe VMerge -> VMerge
forall a b. (a -> b) -> a -> b
$ do
Text
s <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "val" Element
e
case Text
s of
"continue" -> VMerge -> Maybe VMerge
forall a. a -> Maybe a
Just VMerge
Continue
"restart" -> VMerge -> Maybe VMerge
forall a. a -> Maybe a
Just VMerge
Restart
_ -> Maybe VMerge
forall a. Maybe a
Nothing
[BodyPart]
cellContents <- (Element -> D BodyPart)
-> [Element]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart]
forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D BodyPart
elemToBodyPart NameSpaces
ns) (Element -> [Element]
elChildren Element
element)
Cell -> D Cell
forall (m :: * -> *) a. Monad m => a -> m a
return (Cell -> D Cell) -> Cell -> D Cell
forall a b. (a -> b) -> a -> b
$ Integer -> VMerge -> [BodyPart] -> Cell
Cell (Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe 1 Maybe Integer
gridSpan) VMerge
vMerge [BodyPart]
cellContents
elemToCell _ _ = DocxError -> D Cell
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
testBitMask :: Text -> Int -> Bool
testBitMask :: Text -> Int -> Bool
testBitMask bitMaskS :: Text
bitMaskS n :: Int
n =
case (ReadS Int
forall a. Read a => ReadS a
reads ("0x" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
bitMaskS) :: [(Int, String)]) of
[] -> Bool
False
((n' :: Int
n', _) : _) -> (Int
n' Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
n) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0
pHeading :: ParagraphStyle -> Maybe (ParaStyleName, Int)
pHeading :: ParagraphStyle -> Maybe (ParaStyleName, Int)
pHeading = (ParStyle -> Maybe (ParaStyleName, Int))
-> [ParStyle] -> Maybe (ParaStyleName, Int)
forall a. (ParStyle -> Maybe a) -> [ParStyle] -> Maybe a
getParStyleField ParStyle -> Maybe (ParaStyleName, Int)
headingLev ([ParStyle] -> Maybe (ParaStyleName, Int))
-> (ParagraphStyle -> [ParStyle])
-> ParagraphStyle
-> Maybe (ParaStyleName, Int)
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 = (ParStyle -> Maybe (Text, Text))
-> [ParStyle] -> Maybe (Text, Text)
forall a. (ParStyle -> Maybe a) -> [ParStyle] -> Maybe a
getParStyleField ParStyle -> Maybe (Text, Text)
numInfo ([ParStyle] -> Maybe (Text, Text))
-> (ParagraphStyle -> [ParStyle])
-> ParagraphStyle
-> Maybe (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParagraphStyle -> [ParStyle]
pStyle
pStyleIndentation :: ParagraphStyle -> Maybe ParIndentation
pStyleIndentation :: ParagraphStyle -> Maybe ParIndentation
pStyleIndentation style :: ParagraphStyle
style = ((ParStyle -> Maybe ParIndentation)
-> [ParStyle] -> Maybe ParIndentation
forall a. (ParStyle -> Maybe a) -> [ParStyle] -> Maybe a
getParStyleField ParStyle -> Maybe ParIndentation
indent ([ParStyle] -> Maybe ParIndentation)
-> (ParagraphStyle -> [ParStyle])
-> ParagraphStyle
-> Maybe ParIndentation
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 ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "p" Element
element
, (c :: Element
c:_) <- NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns "m" "oMathPara" Element
element = do
[Exp]
expsLst <- Either Text [Exp] -> D [Exp]
forall a b. Either a b -> D b
eitherToD (Either Text [Exp] -> D [Exp]) -> Either Text [Exp] -> D [Exp]
forall a b. (a -> b) -> a -> b
$ Text -> Either Text [Exp]
readOMML (Text -> Either Text [Exp]) -> Text -> Either Text [Exp]
forall a b. (a -> b) -> a -> b
$ Element -> Text
showElement Element
c
BodyPart -> D BodyPart
forall (m :: * -> *) a. Monad m => a -> m a
return (BodyPart -> D BodyPart) -> BodyPart -> D BodyPart
forall a b. (a -> b) -> a -> b
$ [Exp] -> BodyPart
OMathPara [Exp]
expsLst
elemToBodyPart ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "p" Element
element
, Just (numId :: Text
numId, lvl :: Text
lvl) <- NameSpaces -> Element -> Maybe (Text, Text)
getNumInfo NameSpaces
ns Element
element = do
ParagraphStyle
parstyle <- NameSpaces -> Element -> ParStyleMap -> ParagraphStyle
elemToParagraphStyle NameSpaces
ns Element
element (ParStyleMap -> ParagraphStyle)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) ParStyleMap
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) ParagraphStyle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReaderEnv -> ParStyleMap)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) ParStyleMap
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> ParStyleMap
envParStyles
[ParPart]
parparts <- [[ParPart]] -> [ParPart]
forall a. Monoid a => [a] -> a
mconcat ([[ParPart]] -> [ParPart])
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [[ParPart]]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart])
-> [Element]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [[ParPart]]
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)
Maybe Level
levelInfo <- Text -> Text -> Numbering -> Maybe Level
lookupLevel Text
numId Text
lvl (Numbering -> Maybe Level)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) Numbering
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) (Maybe Level)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReaderEnv -> Numbering)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) Numbering
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> Numbering
envNumbering
BodyPart -> D BodyPart
forall (m :: * -> *) a. Monad m => a -> m a
return (BodyPart -> D BodyPart) -> BodyPart -> D BodyPart
forall a b. (a -> b) -> a -> b
$ ParagraphStyle
-> Text -> Text -> Maybe Level -> [ParPart] -> BodyPart
ListItem ParagraphStyle
parstyle Text
numId Text
lvl Maybe Level
levelInfo [ParPart]
parparts
elemToBodyPart ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "p" Element
element = do
ParagraphStyle
parstyle <- NameSpaces -> Element -> ParStyleMap -> ParagraphStyle
elemToParagraphStyle NameSpaces
ns Element
element (ParStyleMap -> ParagraphStyle)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) ParStyleMap
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) ParagraphStyle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReaderEnv -> ParStyleMap)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) ParStyleMap
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> ParStyleMap
envParStyles
[ParPart]
parparts' <- [[ParPart]] -> [ParPart]
forall a. Monoid a => [a] -> a
mconcat ([[ParPart]] -> [ParPart])
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [[ParPart]]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart])
-> [Element]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [[ParPart]]
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)
[FldCharState]
fldCharState <- (ReaderState -> [FldCharState])
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [FldCharState]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ReaderState -> [FldCharState]
stateFldCharState
(ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ())
-> (ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall a b. (a -> b) -> a -> b
$ \st :: ReaderState
st -> ReaderState
st {stateFldCharState :: [FldCharState]
stateFldCharState = [FldCharState] -> [FldCharState]
emptyFldCharContents [FldCharState]
fldCharState}
let parparts :: [ParPart]
parparts = [ParPart]
parparts' [ParPart] -> [ParPart] -> [ParPart]
forall a. [a] -> [a] -> [a]
++ ([FldCharState] -> [ParPart]
openFldCharsToParParts [FldCharState]
fldCharState) in
case ParagraphStyle -> Maybe (ParaStyleName, Int)
pHeading ParagraphStyle
parstyle of
Nothing | Just (numId :: Text
numId, lvl :: Text
lvl) <- ParagraphStyle -> Maybe (Text, Text)
pNumInfo ParagraphStyle
parstyle -> do
Maybe Level
levelInfo <- Text -> Text -> Numbering -> Maybe Level
lookupLevel Text
numId Text
lvl (Numbering -> Maybe Level)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) Numbering
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) (Maybe Level)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReaderEnv -> Numbering)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) Numbering
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> Numbering
envNumbering
BodyPart -> D BodyPart
forall (m :: * -> *) a. Monad m => a -> m a
return (BodyPart -> D BodyPart) -> BodyPart -> D BodyPart
forall a b. (a -> b) -> a -> b
$ ParagraphStyle
-> Text -> Text -> Maybe Level -> [ParPart] -> BodyPart
ListItem ParagraphStyle
parstyle Text
numId Text
lvl Maybe Level
levelInfo [ParPart]
parparts
_ -> let
hasCaptionStyle :: Bool
hasCaptionStyle = ParaStyleId -> [ParaStyleId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem "Caption" (ParStyle -> ParaStyleId
pStyleId (ParStyle -> ParaStyleId) -> [ParStyle] -> [ParaStyleId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParagraphStyle -> [ParStyle]
pStyle ParagraphStyle
parstyle)
hasSimpleTableField :: Bool
hasSimpleTableField = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
Element
fldSimple <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "fldSimple" Element
element
Text
instr <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "instr" Element
fldSimple
Bool -> Maybe Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure ("Table" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Text -> [Text]
T.words Text
instr)
hasComplexTableField :: Bool
hasComplexTableField = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
Element
instrText <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findElementByName NameSpaces
ns "w" "instrText" Element
element
Bool -> Maybe Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure ("Table" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Text -> [Text]
T.words (Element -> Text
strContent Element
instrText))
in if Bool
hasCaptionStyle Bool -> Bool -> Bool
&& (Bool
hasSimpleTableField Bool -> Bool -> Bool
|| Bool
hasComplexTableField)
then BodyPart -> D BodyPart
forall (m :: * -> *) a. Monad m => a -> m a
return (BodyPart -> D BodyPart) -> BodyPart -> D BodyPart
forall a b. (a -> b) -> a -> b
$ ParagraphStyle -> [ParPart] -> BodyPart
TblCaption ParagraphStyle
parstyle [ParPart]
parparts
else BodyPart -> D BodyPart
forall (m :: * -> *) a. Monad m => a -> m a
return (BodyPart -> D BodyPart) -> BodyPart -> D BodyPart
forall a b. (a -> b) -> a -> b
$ ParagraphStyle -> [ParPart] -> BodyPart
Paragraph ParagraphStyle
parstyle [ParPart]
parparts
elemToBodyPart ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "tbl" Element
element = do
let tblProperties :: Maybe Element
tblProperties = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "tblPr" Element
element
caption :: Text
caption = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Maybe Element
tblProperties
Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "tblCaption"
Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "val"
description :: Text
description = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Maybe Element
tblProperties
Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "tblDescription"
Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "val"
grid' :: D TblGrid
grid' = case NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "tblGrid" Element
element of
Just g :: Element
g -> NameSpaces -> Element -> D TblGrid
elemToTblGrid NameSpaces
ns Element
g
Nothing -> TblGrid -> D TblGrid
forall (m :: * -> *) a. Monad m => a -> m a
return []
tblLook' :: D TblLook
tblLook' = case NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "tblPr" Element
element Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "tblLook"
of
Just l :: Element
l -> NameSpaces -> Element -> D TblLook
elemToTblLook NameSpaces
ns Element
l
Nothing -> TblLook -> D TblLook
forall (m :: * -> *) a. Monad m => a -> m a
return TblLook
defaultTblLook
TblGrid
grid <- D TblGrid
grid'
TblLook
tblLook <- D TblLook
tblLook'
[Row]
rows <- (Element -> D Row) -> [Element] -> D [Row]
forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D Row
elemToRow NameSpaces
ns) (Element -> [Element]
elChildren Element
element)
BodyPart -> D BodyPart
forall (m :: * -> *) a. Monad m => a -> m a
return (BodyPart -> D BodyPart) -> BodyPart -> D BodyPart
forall a b. (a -> b) -> a -> b
$ Text -> TblGrid -> TblLook -> [Row] -> BodyPart
Tbl (Text
caption Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
description) TblGrid
grid TblLook
tblLook [Row]
rows
elemToBodyPart _ _ = DocxError -> D BodyPart
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 docLocation :: DocumentLocation
docLocation relid :: Text
relid rels :: [Relationship]
rels =
(DocumentLocation, Text)
-> [((DocumentLocation, Text), Text)] -> Maybe Text
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 = (Relationship -> ((DocumentLocation, Text), Text))
-> [Relationship] -> [((DocumentLocation, Text), Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Relationship loc :: DocumentLocation
loc relid' :: Text
relid' target :: Text
target) -> ((DocumentLocation
loc, Text
relid'), Text
target)) [Relationship]
rels
openFldCharsToParParts :: [FldCharState] -> [ParPart]
openFldCharsToParParts :: [FldCharState] -> [ParPart]
openFldCharsToParParts [] = []
openFldCharsToParParts (FldCharContent info :: FieldInfo
info children :: [ParPart]
children : ancestors :: [FldCharState]
ancestors) = case [FldCharState] -> [ParPart]
openFldCharsToParParts [FldCharState]
ancestors of
Field parentInfo :: FieldInfo
parentInfo siblings :: [ParPart]
siblings : _ -> [FieldInfo -> [ParPart] -> ParPart
Field FieldInfo
parentInfo ([ParPart] -> ParPart) -> [ParPart] -> ParPart
forall a b. (a -> b) -> a -> b
$ [ParPart]
siblings [ParPart] -> [ParPart] -> [ParPart]
forall a. [a] -> [a] -> [a]
++ [FieldInfo -> [ParPart] -> ParPart
Field FieldInfo
info ([ParPart] -> ParPart) -> [ParPart] -> ParPart
forall a b. (a -> b) -> a -> b
$ [ParPart] -> [ParPart]
forall a. [a] -> [a]
reverse [ParPart]
children]]
_ -> [FieldInfo -> [ParPart] -> ParPart
Field FieldInfo
info ([ParPart] -> ParPart) -> [ParPart] -> ParPart
forall a b. (a -> b) -> a -> b
$ [ParPart] -> [ParPart]
forall a. [a] -> [a]
reverse [ParPart]
children]
openFldCharsToParParts (_ : ancestors :: [FldCharState]
ancestors) = [FldCharState] -> [ParPart]
openFldCharsToParParts [FldCharState]
ancestors
emptyFldCharContents :: [FldCharState] -> [FldCharState]
emptyFldCharContents :: [FldCharState] -> [FldCharState]
emptyFldCharContents = (FldCharState -> FldCharState) -> [FldCharState] -> [FldCharState]
forall a b. (a -> b) -> [a] -> [b]
map
(\x :: FldCharState
x -> case FldCharState
x of
FldCharContent info :: FieldInfo
info _ -> FieldInfo -> [ParPart] -> FldCharState
FldCharContent FieldInfo
info []
_ -> FldCharState
x)
expandDrawingId :: T.Text -> D (FilePath, B.ByteString)
expandDrawingId :: Text -> D (FilePath, ByteString)
expandDrawingId s :: Text
s = do
DocumentLocation
location <- (ReaderEnv -> DocumentLocation)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) DocumentLocation
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> DocumentLocation
envLocation
Maybe FilePath
target <- (ReaderEnv -> Maybe FilePath)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) (Maybe FilePath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Text -> FilePath) -> Maybe Text -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> FilePath
T.unpack (Maybe Text -> Maybe FilePath)
-> (ReaderEnv -> Maybe Text) -> ReaderEnv -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocumentLocation -> Text -> [Relationship] -> Maybe Text
lookupRelationship DocumentLocation
location Text
s ([Relationship] -> Maybe Text)
-> (ReaderEnv -> [Relationship]) -> ReaderEnv -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderEnv -> [Relationship]
envRelationships)
case Maybe FilePath
target of
Just filepath :: FilePath
filepath -> do
Media
media <- (ReaderEnv -> Media)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) Media
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> Media
envMedia
let filepath' :: FilePath
filepath' = case FilePath
filepath of
('/':rest :: FilePath
rest) -> FilePath
rest
_ -> "word/" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
filepath
case FilePath -> Media -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
filepath' Media
media of
Just bs :: ByteString
bs -> (FilePath, ByteString) -> D (FilePath, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
filepath, ByteString
bs)
Nothing -> DocxError -> D (FilePath, ByteString)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
DocxError
Nothing -> DocxError -> D (FilePath, ByteString)
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 ns :: NameSpaces
ns element :: Element
element =
let mbDocPr :: Maybe Element
mbDocPr = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "wp" "inline" Element
element Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "wp" "docPr"
title :: Text
title = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe Element
mbDocPr Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "" "title")
alt :: Text
alt = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe Element
mbDocPr Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "" "descr")
in (Text
title, Text
alt)
elemToParPart :: NameSpaces -> Element -> D [ParPart]
elemToParPart :: NameSpaces
-> Element
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
elemToParPart ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "r" Element
element
, Just fldChar :: Element
fldChar <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "fldChar" Element
element
, Just fldCharType :: Text
fldCharType <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "fldCharType" Element
fldChar = do
[FldCharState]
fldCharState <- (ReaderState -> [FldCharState])
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [FldCharState]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ReaderState -> [FldCharState]
stateFldCharState
case [FldCharState]
fldCharState of
_ | Text
fldCharType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "begin" -> do
(ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ())
-> (ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall a b. (a -> b) -> a -> b
$ \st :: ReaderState
st -> ReaderState
st {stateFldCharState :: [FldCharState]
stateFldCharState = FldCharState
FldCharOpen FldCharState -> [FldCharState] -> [FldCharState]
forall a. a -> [a] -> [a]
: [FldCharState]
fldCharState}
[ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return []
FldCharFieldInfo info :: FieldInfo
info : ancestors :: [FldCharState]
ancestors | Text
fldCharType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "separate" -> do
(ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ())
-> (ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall a b. (a -> b) -> a -> b
$ \st :: ReaderState
st -> ReaderState
st {stateFldCharState :: [FldCharState]
stateFldCharState = FieldInfo -> [ParPart] -> FldCharState
FldCharContent FieldInfo
info [] FldCharState -> [FldCharState] -> [FldCharState]
forall a. a -> [a] -> [a]
: [FldCharState]
ancestors}
[ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return []
FldCharFieldInfo _ : ancestors :: [FldCharState]
ancestors | Text
fldCharType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "end" -> do
(ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ())
-> (ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall a b. (a -> b) -> a -> b
$ \st :: ReaderState
st -> ReaderState
st {stateFldCharState :: [FldCharState]
stateFldCharState = [FldCharState]
ancestors}
[ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return []
[FldCharContent info :: FieldInfo
info children :: [ParPart]
children] | Text
fldCharType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "end" -> do
(ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ())
-> (ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall a b. (a -> b) -> a -> b
$ \st :: ReaderState
st -> ReaderState
st {stateFldCharState :: [FldCharState]
stateFldCharState = []}
[ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return [FieldInfo -> [ParPart] -> ParPart
Field FieldInfo
info ([ParPart] -> ParPart) -> [ParPart] -> ParPart
forall a b. (a -> b) -> a -> b
$ [ParPart] -> [ParPart]
forall a. [a] -> [a]
reverse [ParPart]
children]
FldCharContent info :: FieldInfo
info children :: [ParPart]
children : FldCharContent parentInfo :: FieldInfo
parentInfo siblings :: [ParPart]
siblings : ancestors :: [FldCharState]
ancestors | Text
fldCharType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "end" ->
let parent :: FldCharState
parent = FieldInfo -> [ParPart] -> FldCharState
FldCharContent FieldInfo
parentInfo ([ParPart] -> FldCharState) -> [ParPart] -> FldCharState
forall a b. (a -> b) -> a -> b
$ (FieldInfo -> [ParPart] -> ParPart
Field FieldInfo
info ([ParPart] -> [ParPart]
forall a. [a] -> [a]
reverse [ParPart]
children)) ParPart -> [ParPart] -> [ParPart]
forall a. a -> [a] -> [a]
: [ParPart]
siblings in do
(ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ())
-> (ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall a b. (a -> b) -> a -> b
$ \st :: ReaderState
st -> ReaderState
st {stateFldCharState :: [FldCharState]
stateFldCharState = FldCharState
parent FldCharState -> [FldCharState] -> [FldCharState]
forall a. a -> [a] -> [a]
: [FldCharState]
ancestors}
[ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return []
_ -> DocxError
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
elemToParPart ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "r" Element
element
, Just instrText :: Element
instrText <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "instrText" Element
element = do
[FldCharState]
fldCharState <- (ReaderState -> [FldCharState])
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [FldCharState]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ReaderState -> [FldCharState]
stateFldCharState
case [FldCharState]
fldCharState of
FldCharOpen : ancestors :: [FldCharState]
ancestors -> do
FieldInfo
info <- Either ParseError FieldInfo -> D FieldInfo
forall a b. Either a b -> D b
eitherToD (Either ParseError FieldInfo -> D FieldInfo)
-> Either ParseError FieldInfo -> D FieldInfo
forall a b. (a -> b) -> a -> b
$ Text -> Either ParseError FieldInfo
parseFieldInfo (Text -> Either ParseError FieldInfo)
-> Text -> Either ParseError FieldInfo
forall a b. (a -> b) -> a -> b
$ Element -> Text
strContent Element
instrText
(ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ())
-> (ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall a b. (a -> b) -> a -> b
$ \st :: ReaderState
st -> ReaderState
st {stateFldCharState :: [FldCharState]
stateFldCharState = FieldInfo -> FldCharState
FldCharFieldInfo FieldInfo
info FldCharState -> [FldCharState] -> [FldCharState]
forall a. a -> [a] -> [a]
: [FldCharState]
ancestors}
[ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return []
_ -> [ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return []
elemToParPart ns :: NameSpaces
ns element :: Element
element = do
[FldCharState]
fldCharState <- (ReaderState -> [FldCharState])
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [FldCharState]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ReaderState -> [FldCharState]
stateFldCharState
case [FldCharState]
fldCharState of
FldCharContent info :: FieldInfo
info children :: [ParPart]
children : ancestors :: [FldCharState]
ancestors -> do
(ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ())
-> (ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall a b. (a -> b) -> a -> b
$ \st :: ReaderState
st -> ReaderState
st {stateFldCharState :: [FldCharState]
stateFldCharState = []}
[ParPart]
parParts <- NameSpaces
-> Element
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
elemToParPart' NameSpaces
ns Element
element ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
-> (DocxError
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart])
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \_ -> [ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return []
(ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ())
-> (ReaderState -> ReaderState)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) ()
forall a b. (a -> b) -> a -> b
$ \st :: ReaderState
st -> ReaderState
st{stateFldCharState :: [FldCharState]
stateFldCharState = FieldInfo -> [ParPart] -> FldCharState
FldCharContent FieldInfo
info ([ParPart]
parParts [ParPart] -> [ParPart] -> [ParPart]
forall a. [a] -> [a] -> [a]
++ [ParPart]
children) FldCharState -> [FldCharState] -> [FldCharState]
forall a. a -> [a] -> [a]
: [FldCharState]
ancestors}
[ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return []
_ -> 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' ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "r" Element
element
, Just drawingElem :: Element
drawingElem <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "drawing" Element
element
, Text
pic_ns <- "http://schemas.openxmlformats.org/drawingml/2006/picture"
, [Element]
picElems <- QName -> Element -> [Element]
findElements (Text -> Maybe Text -> Maybe Text -> QName
QName "pic" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
pic_ns) (Text -> Maybe Text
forall a. a -> Maybe a
Just "pic")) Element
drawingElem
= let (title :: Text
title, alt :: Text
alt) = NameSpaces -> Element -> (Text, Text)
getTitleAndAlt NameSpaces
ns Element
drawingElem
a_ns :: Text
a_ns = "http://schemas.openxmlformats.org/drawingml/2006/main"
drawings :: [(Maybe Text, Element)]
drawings = (Element -> (Maybe Text, Element))
-> [Element] -> [(Maybe Text, Element)]
forall a b. (a -> b) -> [a] -> [b]
map (\el :: Element
el ->
((QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName "blip" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
a_ns) (Text -> Maybe Text
forall a. a -> Maybe a
Just "a")) Element
el
Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "r" "embed"), Element
el)) [Element]
picElems
in ((Maybe Text, Element)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) ParPart)
-> [(Maybe Text, Element)]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\case
(Just s :: Text
s, el :: Element
el) -> do
(fp :: FilePath
fp, bs :: ByteString
bs) <- Text -> D (FilePath, ByteString)
expandDrawingId Text
s
let extent :: Maybe (Double, Double)
extent = Element -> Maybe (Double, Double)
elemToExtent Element
el Maybe (Double, Double)
-> Maybe (Double, Double) -> Maybe (Double, Double)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Element -> Maybe (Double, Double)
elemToExtent Element
element
ParPart
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return (ParPart
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) ParPart)
-> ParPart
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) ParPart
forall a b. (a -> b) -> a -> b
$ FilePath
-> Text -> Text -> ByteString -> Maybe (Double, Double) -> ParPart
Drawing FilePath
fp Text
title Text
alt ByteString
bs Maybe (Double, Double)
extent
(Nothing, _) -> DocxError
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) ParPart
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem)
[(Maybe Text, Element)]
drawings
elemToParPart' ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "r" Element
element
, Just _ <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "pict" Element
element =
let drawing :: Maybe Text
drawing = QName -> Element -> Maybe Element
findElement (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "v" "imagedata") Element
element
Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "r" "id"
in
case Maybe Text
drawing of
Just s :: Text
s -> Text -> D (FilePath, ByteString)
expandDrawingId Text
s D (FilePath, ByteString)
-> ((FilePath, ByteString)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart])
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(fp :: FilePath
fp, bs :: ByteString
bs) -> [ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
-> Text -> Text -> ByteString -> Maybe (Double, Double) -> ParPart
Drawing FilePath
fp "" "" ByteString
bs Maybe (Double, Double)
forall a. Maybe a
Nothing])
Nothing -> DocxError
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
elemToParPart' ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "r" Element
element
, Just objectElem :: Element
objectElem <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "object" Element
element
, Just shapeElem :: Element
shapeElem <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "v" "shape" Element
objectElem
, Just imagedataElem :: Element
imagedataElem <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "v" "imagedata" Element
shapeElem
, Just drawingId :: Text
drawingId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "r" "id" Element
imagedataElem
= Text -> D (FilePath, ByteString)
expandDrawingId Text
drawingId D (FilePath, ByteString)
-> ((FilePath, ByteString)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart])
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(fp :: FilePath
fp, bs :: ByteString
bs) -> [ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
-> Text -> Text -> ByteString -> Maybe (Double, Double) -> ParPart
Drawing FilePath
fp "" "" ByteString
bs Maybe (Double, Double)
forall a. Maybe a
Nothing])
elemToParPart' ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "r" Element
element
, Just drawingElem :: Element
drawingElem <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "drawing" Element
element
, Text
d_ns <- "http://schemas.openxmlformats.org/drawingml/2006/diagram"
, Just _ <- QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName "relIds" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
d_ns) (Text -> Maybe Text
forall a. a -> Maybe a
Just "dgm")) Element
drawingElem
= [ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return [ParPart
Diagram]
elemToParPart' ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "r" Element
element
, Just drawingElem :: Element
drawingElem <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "drawing" Element
element
, Text
c_ns <- "http://schemas.openxmlformats.org/drawingml/2006/chart"
, Just _ <- QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName "chart" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
c_ns) (Text -> Maybe Text
forall a. a -> Maybe a
Just "c")) Element
drawingElem
= [ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return [ParPart
Chart]
elemToParPart' ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "r" Element
element = do
[Run]
runs <- NameSpaces -> Element -> D [Run]
elemToRun NameSpaces
ns Element
element
[ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart])
-> [ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall a b. (a -> b) -> a -> b
$ (Run -> ParPart) -> [Run] -> [ParPart]
forall a b. (a -> b) -> [a] -> [b]
map Run -> ParPart
PlainRun [Run]
runs
elemToParPart' ns :: NameSpaces
ns element :: Element
element
| Just change :: TrackedChange
change <- NameSpaces -> Element -> Maybe TrackedChange
getTrackedChange NameSpaces
ns Element
element = do
[Run]
runs <- [[Run]] -> [Run]
forall a. Monoid a => [a] -> a
mconcat ([[Run]] -> [Run])
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [[Run]]
-> D [Run]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element -> D [Run])
-> [Element]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [[Run]]
forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D [Run]
elemToRun NameSpaces
ns) (Element -> [Element]
elChildren Element
element)
[ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return [TrackedChange -> [Run] -> ParPart
ChangedRuns TrackedChange
change [Run]
runs]
elemToParPart' ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "bookmarkStart" Element
element
, Just bmId :: Text
bmId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "id" Element
element
, Just bmName :: Text
bmName <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "name" Element
element =
[ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> Text -> ParPart
BookMark Text
bmId Text
bmName]
elemToParPart' ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "hyperlink" Element
element
, Just relId :: Text
relId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "r" "id" Element
element = do
DocumentLocation
location <- (ReaderEnv -> DocumentLocation)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) DocumentLocation
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> DocumentLocation
envLocation
[ParPart]
children <- [[ParPart]] -> [ParPart]
forall a. Monoid a => [a] -> a
mconcat ([[ParPart]] -> [ParPart])
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [[ParPart]]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart])
-> [Element]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [[ParPart]]
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 <- (ReaderEnv -> [Relationship])
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [Relationship]
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 target :: Text
target ->
case NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "anchor" Element
element of
Just anchor :: Text
anchor -> [ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return
[Text -> [ParPart] -> ParPart
ExternalHyperLink (Text
target Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
anchor) [ParPart]
children]
Nothing -> [ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> [ParPart] -> ParPart
ExternalHyperLink Text
target [ParPart]
children]
Nothing -> [ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> [ParPart] -> ParPart
ExternalHyperLink "" [ParPart]
children]
elemToParPart' ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "hyperlink" Element
element
, Just anchor :: Text
anchor <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "anchor" Element
element = do
[ParPart]
children <- [[ParPart]] -> [ParPart]
forall a. Monoid a => [a] -> a
mconcat ([[ParPart]] -> [ParPart])
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [[ParPart]]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart])
-> [Element]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [[ParPart]]
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)
[ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> [ParPart] -> ParPart
InternalHyperLink Text
anchor [ParPart]
children]
elemToParPart' ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "commentRangeStart" Element
element
, Just cmtId :: Text
cmtId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "id" Element
element = do
(Comments _ commentMap :: Map Text Element
commentMap) <- (ReaderEnv -> Comments)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) Comments
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> Comments
envComments
case Text -> Map Text Element -> Maybe Element
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
cmtId Map Text Element
commentMap of
Just cmtElem :: Element
cmtElem -> NameSpaces
-> Element
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
elemToCommentStart NameSpaces
ns Element
cmtElem
Nothing -> DocxError
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
elemToParPart' ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "commentRangeEnd" Element
element
, Just cmtId :: Text
cmtId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "id" Element
element =
[ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text -> ParPart
CommentEnd Text
cmtId]
elemToParPart' ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "m" "oMath" Element
element =
([Exp] -> [ParPart])
-> D [Exp]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ParPart -> [ParPart]
forall (m :: * -> *) a. Monad m => a -> m a
return (ParPart -> [ParPart]) -> ([Exp] -> ParPart) -> [Exp] -> [ParPart]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> ParPart
PlainOMath) (Either Text [Exp] -> D [Exp]
forall a b. Either a b -> D b
eitherToD (Either Text [Exp] -> D [Exp]) -> Either Text [Exp] -> D [Exp]
forall a b. (a -> b) -> a -> b
$ Text -> Either Text [Exp]
readOMML (Text -> Either Text [Exp]) -> Text -> Either Text [Exp]
forall a b. (a -> b) -> a -> b
$ Element -> Text
showElement Element
element)
elemToParPart' _ _ = DocxError
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
elemToCommentStart :: NameSpaces -> Element -> D [ParPart]
ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "comment" Element
element
, Just cmtId :: Text
cmtId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "id" Element
element
, Just cmtAuthor :: Text
cmtAuthor <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "author" Element
element
, Maybe Text
cmtDate <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "date" Element
element = do
[BodyPart]
bps <- (Element -> D BodyPart)
-> [Element]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart]
forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D BodyPart
elemToBodyPart NameSpaces
ns) (Element -> [Element]
elChildren Element
element)
[ParPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
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 _ _ = DocxError
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [ParPart]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
lookupFootnote :: T.Text -> Notes -> Maybe Element
s :: Text
s (Notes _ fns :: Maybe (Map Text Element)
fns _) = Maybe (Map Text Element)
fns Maybe (Map Text Element)
-> (Map Text Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Map Text Element -> Maybe Element
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 s :: Text
s (Notes _ _ ens :: Maybe (Map Text Element)
ens) = Maybe (Map Text Element)
ens Maybe (Map Text Element)
-> (Map Text Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Map Text Element -> Maybe Element
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
s
elemToExtent :: Element -> Extent
elemToExtent :: Element -> Maybe (Double, Double)
elemToExtent el :: Element
el =
case (Text -> Maybe Double
forall b. Read b => Text -> Maybe b
getDim "cx", Text -> Maybe Double
forall b. Read b => Text -> Maybe b
getDim "cy") of
(Just w :: Double
w, Just h :: Double
h) -> (Double, Double) -> Maybe (Double, Double)
forall a. a -> Maybe a
Just (Double
w, Double
h)
_ -> Maybe (Double, Double)
forall a. Maybe a
Nothing
where
getDim :: Text -> Maybe b
getDim at :: Text
at = (QName -> Bool) -> Element -> Maybe Element
filterElementName (\n :: QName
n -> QName -> Text
qName QName
n Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["extent", "ext"]) Element
el
Maybe Element -> (Element -> Maybe Text) -> Maybe Text
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 Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Maybe Text -> (Text -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe b
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead
childElemToRun :: NameSpaces -> Element -> D [Run]
childElemToRun :: NameSpaces -> Element -> D [Run]
childElemToRun ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "drawing" Element
element
, Text
pic_ns <- "http://schemas.openxmlformats.org/drawingml/2006/picture"
, [Element]
picElems <- QName -> Element -> [Element]
findElements (Text -> Maybe Text -> Maybe Text -> QName
QName "pic" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
pic_ns) (Text -> Maybe Text
forall a. a -> Maybe a
Just "pic")) Element
element
= let (title :: Text
title, alt :: Text
alt) = NameSpaces -> Element -> (Text, Text)
getTitleAndAlt NameSpaces
ns Element
element
a_ns :: Text
a_ns = "http://schemas.openxmlformats.org/drawingml/2006/main"
drawings :: [(Maybe Text, Element)]
drawings = (Element -> (Maybe Text, Element))
-> [Element] -> [(Maybe Text, Element)]
forall a b. (a -> b) -> [a] -> [b]
map (\el :: Element
el ->
((QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName "blip" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
a_ns) (Text -> Maybe Text
forall a. a -> Maybe a
Just "a")) Element
el
Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "r" "embed"), Element
el)) [Element]
picElems
in ((Maybe Text, Element)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) Run)
-> [(Maybe Text, Element)] -> D [Run]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\case
(Just s :: Text
s, el :: Element
el) -> do
(fp :: FilePath
fp, bs :: ByteString
bs) <- Text -> D (FilePath, ByteString)
expandDrawingId Text
s
let extent :: Maybe (Double, Double)
extent = Element -> Maybe (Double, Double)
elemToExtent Element
el Maybe (Double, Double)
-> Maybe (Double, Double) -> Maybe (Double, Double)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Element -> Maybe (Double, Double)
elemToExtent Element
element
Run
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) Run
forall (m :: * -> *) a. Monad m => a -> m a
return (Run
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) Run)
-> Run
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) Run
forall a b. (a -> b) -> a -> b
$ FilePath
-> Text -> Text -> ByteString -> Maybe (Double, Double) -> Run
InlineDrawing FilePath
fp Text
title Text
alt ByteString
bs Maybe (Double, Double)
extent
(Nothing, _) -> DocxError
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) Run
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem)
[(Maybe Text, Element)]
drawings
childElemToRun ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "drawing" Element
element
, Text
c_ns <- "http://schemas.openxmlformats.org/drawingml/2006/chart"
, Just _ <- QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName "chart" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
c_ns) (Text -> Maybe Text
forall a. a -> Maybe a
Just "c")) Element
element
= [Run] -> D [Run]
forall (m :: * -> *) a. Monad m => a -> m a
return [Run
InlineChart]
childElemToRun ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "drawing" Element
element
, Text
c_ns <- "http://schemas.openxmlformats.org/drawingml/2006/diagram"
, Just _ <- QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName "relIds" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
c_ns) (Text -> Maybe Text
forall a. a -> Maybe a
Just "dgm")) Element
element
= [Run] -> D [Run]
forall (m :: * -> *) a. Monad m => a -> m a
return [Run
InlineDiagram]
childElemToRun ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "footnoteReference" Element
element
, Just fnId :: Text
fnId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "id" Element
element = do
Notes
notes <- (ReaderEnv -> Notes)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) 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 e :: Element
e -> do [BodyPart]
bps <- (ReaderEnv -> ReaderEnv)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\r :: ReaderEnv
r -> ReaderEnv
r {envLocation :: DocumentLocation
envLocation=DocumentLocation
InFootnote}) (ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart])
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart]
forall a b. (a -> b) -> a -> b
$ (Element -> D BodyPart)
-> [Element]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart]
forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D BodyPart
elemToBodyPart NameSpaces
ns) (Element -> [Element]
elChildren Element
e)
[Run] -> D [Run]
forall (m :: * -> *) a. Monad m => a -> m a
return [[BodyPart] -> Run
Footnote [BodyPart]
bps]
Nothing -> [Run] -> D [Run]
forall (m :: * -> *) a. Monad m => a -> m a
return [[BodyPart] -> Run
Footnote []]
childElemToRun ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "endnoteReference" Element
element
, Just enId :: Text
enId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "id" Element
element = do
Notes
notes <- (ReaderEnv -> Notes)
-> ExceptT DocxError (ReaderT ReaderEnv (State ReaderState)) 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 e :: Element
e -> do [BodyPart]
bps <- (ReaderEnv -> ReaderEnv)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\r :: ReaderEnv
r -> ReaderEnv
r {envLocation :: DocumentLocation
envLocation=DocumentLocation
InEndnote}) (ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart])
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart]
forall a b. (a -> b) -> a -> b
$ (Element -> D BodyPart)
-> [Element]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [BodyPart]
forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D BodyPart
elemToBodyPart NameSpaces
ns) (Element -> [Element]
elChildren Element
e)
[Run] -> D [Run]
forall (m :: * -> *) a. Monad m => a -> m a
return [[BodyPart] -> Run
Endnote [BodyPart]
bps]
Nothing -> [Run] -> D [Run]
forall (m :: * -> *) a. Monad m => a -> m a
return [[BodyPart] -> Run
Endnote []]
childElemToRun _ _ = DocxError -> D [Run]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
elemToRun :: NameSpaces -> Element -> D [Run]
elemToRun :: NameSpaces -> Element -> D [Run]
elemToRun ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "r" Element
element
, Just altCont :: Element
altCont <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "mc" "AlternateContent" Element
element =
do let choices :: [Element]
choices = NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns "mc" "Choice" Element
altCont
choiceChildren :: [Element]
choiceChildren = ([Element] -> Element) -> [[Element]] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map [Element] -> Element
forall a. [a] -> a
head ([[Element]] -> [Element]) -> [[Element]] -> [Element]
forall a b. (a -> b) -> a -> b
$ ([Element] -> Bool) -> [[Element]] -> [[Element]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Element] -> Bool) -> [Element] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Element] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[Element]] -> [[Element]]) -> [[Element]] -> [[Element]]
forall a b. (a -> b) -> a -> b
$ (Element -> [Element]) -> [Element] -> [[Element]]
forall a b. (a -> b) -> [a] -> [b]
map Element -> [Element]
elChildren [Element]
choices
[[Run]]
outputs <- (Element -> D [Run])
-> [Element]
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) [[Run]]
forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D [Run]
childElemToRun NameSpaces
ns) [Element]
choiceChildren
case [[Run]]
outputs of
r :: [Run]
r : _ -> [Run] -> D [Run]
forall (m :: * -> *) a. Monad m => a -> m a
return [Run]
r
[] -> DocxError -> D [Run]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
elemToRun ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "r" Element
element
, Just drawingElem :: Element
drawingElem <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "drawing" Element
element =
NameSpaces -> Element -> D [Run]
childElemToRun NameSpaces
ns Element
drawingElem
elemToRun ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "r" Element
element
, Just ref :: Element
ref <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "footnoteReference" Element
element =
NameSpaces -> Element -> D [Run]
childElemToRun NameSpaces
ns Element
ref
elemToRun ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "r" Element
element
, Just ref :: Element
ref <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "endnoteReference" Element
element =
NameSpaces -> Element -> D [Run]
childElemToRun NameSpaces
ns Element
ref
elemToRun ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "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
[Run] -> D [Run]
forall (m :: * -> *) a. Monad m => a -> m a
return [RunStyle -> [RunElem] -> Run
Run RunStyle
runStyle [RunElem]
runElems]
elemToRun _ _ = DocxError -> D [Run]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
getParentStyleValue :: (ParStyle -> Maybe a) -> ParStyle -> Maybe a
getParentStyleValue :: (ParStyle -> Maybe a) -> ParStyle -> Maybe a
getParentStyleValue field :: ParStyle -> Maybe a
field style :: ParStyle
style
| Just value :: a
value <- ParStyle -> Maybe a
field ParStyle
style = a -> Maybe a
forall a. a -> Maybe a
Just a
value
| Just parentStyle :: ParStyle
parentStyle <- ParStyle -> Maybe ParStyle
psParentStyle ParStyle
style
= (ParStyle -> Maybe a) -> ParStyle -> Maybe a
forall a. (ParStyle -> Maybe a) -> ParStyle -> Maybe a
getParentStyleValue ParStyle -> Maybe a
field ParStyle
parentStyle
getParentStyleValue _ _ = Maybe a
forall a. Maybe a
Nothing
getParStyleField :: (ParStyle -> Maybe a) -> [ParStyle] -> Maybe a
getParStyleField :: (ParStyle -> Maybe a) -> [ParStyle] -> Maybe a
getParStyleField field :: ParStyle -> Maybe a
field styles :: [ParStyle]
styles
| (y :: a
y:_) <- (ParStyle -> Maybe a) -> [ParStyle] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((ParStyle -> Maybe a) -> ParStyle -> Maybe a
forall a. (ParStyle -> Maybe a) -> ParStyle -> Maybe a
getParentStyleValue ParStyle -> Maybe a
field) [ParStyle]
styles
= a -> Maybe a
forall a. a -> Maybe a
Just a
y
getParStyleField _ _ = Maybe a
forall a. Maybe a
Nothing
getTrackedChange :: NameSpaces -> Element -> Maybe TrackedChange
getTrackedChange :: NameSpaces -> Element -> Maybe TrackedChange
getTrackedChange ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "ins" Element
element Bool -> Bool -> Bool
|| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "moveTo" Element
element
, Just cId :: Text
cId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "id" Element
element
, Just cAuthor :: Text
cAuthor <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "author" Element
element
, Maybe Text
mcDate <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "date" Element
element =
TrackedChange -> Maybe TrackedChange
forall a. a -> Maybe a
Just (TrackedChange -> Maybe TrackedChange)
-> TrackedChange -> Maybe TrackedChange
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 ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "del" Element
element Bool -> Bool -> Bool
|| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "moveFrom" Element
element
, Just cId :: Text
cId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "id" Element
element
, Just cAuthor :: Text
cAuthor <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "author" Element
element
, Maybe Text
mcDate <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "date" Element
element =
TrackedChange -> Maybe TrackedChange
forall a. a -> Maybe a
Just (TrackedChange -> Maybe TrackedChange)
-> TrackedChange -> Maybe TrackedChange
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 _ _ = Maybe TrackedChange
forall a. Maybe a
Nothing
elemToParagraphStyle :: NameSpaces -> Element -> ParStyleMap -> ParagraphStyle
elemToParagraphStyle :: NameSpaces -> Element -> ParStyleMap -> ParagraphStyle
elemToParagraphStyle ns :: NameSpaces
ns element :: Element
element sty :: ParStyleMap
sty
| Just pPr :: Element
pPr <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "pPr" Element
element =
let style :: [ParaStyleId]
style =
(Element -> Maybe ParaStyleId) -> [Element] -> [ParaStyleId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
((Text -> ParaStyleId) -> Maybe Text -> Maybe ParaStyleId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ParaStyleId
ParaStyleId (Maybe Text -> Maybe ParaStyleId)
-> (Element -> Maybe Text) -> Element -> Maybe ParaStyleId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "val")
(NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns "w" "pStyle" Element
pPr)
in ParagraphStyle :: [ParStyle]
-> Maybe ParIndentation
-> Bool
-> Maybe TrackedChange
-> Maybe Bool
-> ParagraphStyle
ParagraphStyle
{pStyle :: [ParStyle]
pStyle = (ParaStyleId -> Maybe ParStyle) -> [ParaStyleId] -> [ParStyle]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (ParaStyleId -> ParStyleMap -> Maybe ParStyle
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` ParStyleMap
sty) [ParaStyleId]
style
, 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 "w" "framePr" Element
pPr Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "dropCap"
of
Just "none" -> Bool
False
Just _ -> Bool
True
Nothing -> Bool
False
, pChange :: Maybe TrackedChange
pChange = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "rPr" Element
pPr Maybe Element -> (Element -> Maybe Element) -> Maybe Element
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(Element -> Bool) -> Element -> Maybe Element
filterChild (\e :: Element
e -> NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "ins" Element
e Bool -> Bool -> Bool
||
NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "moveTo" Element
e Bool -> Bool -> Bool
||
NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "del" Element
e Bool -> Bool -> Bool
||
NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "moveFrom" Element
e
) Maybe Element
-> (Element -> Maybe TrackedChange) -> Maybe TrackedChange
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 "w" "bidi")
}
elemToParagraphStyle _ _ _ = ParagraphStyle
defaultParagraphStyle
elemToRunStyleD :: NameSpaces -> Element -> D RunStyle
elemToRunStyleD :: NameSpaces -> Element -> D RunStyle
elemToRunStyleD ns :: NameSpaces
ns element :: Element
element
| Just rPr :: Element
rPr <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns "w" "rPr" Element
element = do
CharStyleMap
charStyles <- (ReaderEnv -> CharStyleMap)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) CharStyleMap
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 "w" "rStyle" Element
rPr Maybe Element -> (Element -> Maybe Text) -> Maybe Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "val" Maybe Text -> (Text -> Maybe CharStyle) -> Maybe CharStyle
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(CharStyleId -> CharStyleMap -> Maybe CharStyle)
-> CharStyleMap -> CharStyleId -> Maybe CharStyle
forall a b c. (a -> b -> c) -> b -> a -> c
flip CharStyleId -> CharStyleMap -> Maybe CharStyle
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup CharStyleMap
charStyles (CharStyleId -> Maybe CharStyle)
-> (Text -> CharStyleId) -> Text -> Maybe CharStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> CharStyleId
CharStyleId
RunStyle -> D RunStyle
forall (m :: * -> *) a. Monad m => a -> m a
return (RunStyle -> D RunStyle) -> RunStyle -> D RunStyle
forall a b. (a -> b) -> a -> b
$ NameSpaces -> Element -> Maybe CharStyle -> RunStyle
elemToRunStyle NameSpaces
ns Element
element Maybe CharStyle
parentSty
elemToRunStyleD _ _ = RunStyle -> D RunStyle
forall (m :: * -> *) a. Monad m => a -> m a
return RunStyle
defaultRunStyle
elemToRunElem :: NameSpaces -> Element -> D RunElem
elemToRunElem :: NameSpaces -> Element -> D RunElem
elemToRunElem ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "t" Element
element
Bool -> Bool -> Bool
|| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "delText" Element
element
Bool -> Bool -> Bool
|| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "m" "t" Element
element = do
let str :: Text
str = Element -> Text
strContent Element
element
Maybe Font
font <- (ReaderEnv -> Maybe Font)
-> ExceptT
DocxError (ReaderT ReaderEnv (State ReaderState)) (Maybe Font)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> Maybe Font
envFont
case Maybe Font
font of
Nothing -> RunElem -> D RunElem
forall (m :: * -> *) a. Monad m => a -> m a
return (RunElem -> D RunElem) -> RunElem -> D RunElem
forall a b. (a -> b) -> a -> b
$ Text -> RunElem
TextRun Text
str
Just f :: Font
f -> RunElem -> D RunElem
forall (m :: * -> *) a. Monad m => a -> m a
return (RunElem -> D RunElem) -> (Text -> RunElem) -> Text -> D RunElem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> RunElem
TextRun (Text -> D RunElem) -> Text -> D RunElem
forall a b. (a -> b) -> a -> b
$
(Char -> Char) -> Text -> Text
T.map (\x :: Char
x -> Char -> Maybe Char -> Char
forall a. a -> Maybe a -> a
fromMaybe Char
x (Maybe Char -> Char) -> (Char -> Maybe Char) -> Char -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Font -> Char -> Maybe Char
getUnicode Font
f (Char -> Maybe Char) -> (Char -> Char) -> Char -> Maybe Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
lowerFromPrivate (Char -> Char) -> Char -> Char
forall a b. (a -> b) -> a -> b
$ Char
x) Text
str
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "br" Element
element = RunElem -> D RunElem
forall (m :: * -> *) a. Monad m => a -> m a
return RunElem
LnBrk
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "tab" Element
element = RunElem -> D RunElem
forall (m :: * -> *) a. Monad m => a -> m a
return RunElem
Tab
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "softHyphen" Element
element = RunElem -> D RunElem
forall (m :: * -> *) a. Monad m => a -> m a
return RunElem
SoftHyphen
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "noBreakHyphen" Element
element = RunElem -> D RunElem
forall (m :: * -> *) a. Monad m => a -> m a
return RunElem
NoBreakHyphen
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "sym" Element
element = RunElem -> D RunElem
forall (m :: * -> *) a. Monad m => a -> m a
return (NameSpaces -> Element -> RunElem
getSymChar NameSpaces
ns Element
element)
| Bool
otherwise = DocxError -> D RunElem
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Char -> Int
ord '\xF000' = Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord '\xF000'
| Bool
otherwise = Int -> Char
chr Int
c
getSymChar :: NameSpaces -> Element -> RunElem
getSymChar :: NameSpaces -> Element -> RunElem
getSymChar ns :: NameSpaces
ns element :: Element
element
| Just s :: Text
s <- Text -> Text
lowerFromPrivate (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
getCodepoint
, Just font :: Font
font <- Maybe Font
getFont =
case ReadS Char
readLitChar ("\\x" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
s) of
[(char :: Char
char, _)] -> Text -> RunElem
TextRun (Text -> RunElem) -> (Maybe Char -> Text) -> Maybe Char -> RunElem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> (Char -> Text) -> Maybe Char -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" Char -> Text
T.singleton (Maybe Char -> RunElem) -> Maybe Char -> RunElem
forall a b. (a -> b) -> a -> b
$ Font -> Char -> Maybe Char
getUnicode Font
font Char
char
_ -> Text -> RunElem
TextRun ""
where
getCodepoint :: Maybe Text
getCodepoint = NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "char" Element
element
getFont :: Maybe Font
getFont = Text -> Maybe Font
textToFont (Text -> Maybe Font) -> Maybe Text -> Maybe Font
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns "w" "font" Element
element
lowerFromPrivate :: Text -> Text
lowerFromPrivate t :: Text
t | "F" Text -> Text -> Bool
`T.isPrefixOf` Text
t = "0" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.drop 1 Text
t
| Bool
otherwise = Text
t
getSymChar _ _ = Text -> RunElem
TextRun ""
elemToRunElems :: NameSpaces -> Element -> D [RunElem]
elemToRunElems :: NameSpaces -> Element -> D [RunElem]
elemToRunElems ns :: NameSpaces
ns element :: Element
element
| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "w" "r" Element
element
Bool -> Bool -> Bool
|| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns "m" "r" Element
element = do
let qualName :: Text -> QName
qualName = NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns "w"
let font :: Maybe Font
font = do
Element
fontElem <- QName -> Element -> Maybe Element
findElement (Text -> QName
qualName "rFonts") Element
element
Text -> Maybe Font
textToFont (Text -> Maybe Font) -> Maybe Text -> Maybe Font
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(Text -> Maybe Text -> Maybe Text)
-> Maybe Text -> [Text] -> Maybe Text
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) (Maybe Text -> Maybe Text -> Maybe Text)
-> (Text -> Maybe Text) -> Text -> Maybe Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((QName -> Element -> Maybe Text) -> Element -> QName -> Maybe Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip QName -> Element -> Maybe Text
findAttr Element
fontElem (QName -> Maybe Text) -> (Text -> QName) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> QName
qualName))
Maybe Text
forall a. Maybe a
Nothing ["ascii", "hAnsi"]
(ReaderEnv -> ReaderEnv) -> D [RunElem] -> D [RunElem]
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Maybe Font -> ReaderEnv -> ReaderEnv
setFont Maybe Font
font) ((Element -> D RunElem) -> [Element] -> D [RunElem]
forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D RunElem
elemToRunElem NameSpaces
ns) (Element -> [Element]
elChildren Element
element))
elemToRunElems _ _ = DocxError -> D [RunElem]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
setFont :: Maybe Font -> ReaderEnv -> ReaderEnv
setFont :: Maybe Font -> ReaderEnv -> ReaderEnv
setFont f :: Maybe Font
f s :: ReaderEnv
s = ReaderEnv
s{envFont :: Maybe Font
envFont = Maybe Font
f}