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

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

Conversion of docx archive into Docx haskell type
-}

module Text.Pandoc.Readers.Docx.Parse ( Docx(..)
                                      , Document(..)
                                      , Body(..)
                                      , BodyPart(..)
                                      , TblLook(..)
                                      , Extent
                                      , ParPart(..)
                                      , Run(..)
                                      , RunElem(..)
                                      , Notes
                                      , Numbering
                                      , Relationship
                                      , Media
                                      , RunStyle(..)
                                      , VertAlign(..)
                                      , ParIndentation(..)
                                      , ParagraphStyle(..)
                                      , ParStyle
                                      , CharStyle(cStyleData)
                                      , Row(..)
                                      , Cell(..)
                                      , TrackedChange(..)
                                      , ChangeType(..)
                                      , ChangeInfo(..)
                                      , FieldInfo(..)
                                      , Level(..)
                                      , ParaStyleName
                                      , CharStyleName
                                      , FromStyleName(..)
                                      , HasStyleName(..)
                                      , HasParentStyle(..)
                                      , archiveToDocx
                                      , archiveToDocxWithWarnings
                                      , getStyleNames
                                      , pHeading
                                      , constructBogusParStyleData
                                      , leftBiasedMergeRunStyle
                                      ) 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

data ReaderEnv = ReaderEnv { ReaderEnv -> Notes
envNotes         :: Notes
                           , ReaderEnv -> Comments
envComments      :: Comments
                           , ReaderEnv -> Numbering
envNumbering     :: Numbering
                           , ReaderEnv -> [Relationship]
envRelationships :: [Relationship]
                           , ReaderEnv -> Media
envMedia         :: Media
                           , ReaderEnv -> Maybe Font
envFont          :: Maybe Font
                           , ReaderEnv -> CharStyleMap
envCharStyles    :: CharStyleMap
                           , ReaderEnv -> ParStyleMap
envParStyles     :: ParStyleMap
                           , ReaderEnv -> DocumentLocation
envLocation      :: DocumentLocation
                           , ReaderEnv -> 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 [Run]
                  | FldCharClosed
                  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 D a
dx ReaderEnv
re 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 -> D a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
maybeToD Maybe a
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 -> D b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
eitherToD (Left a
_)  = 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 a -> m [b]
f [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)

-- This is similar to `mapMaybe`: it maps a function returning the D
-- monad over a list, and only keeps the non-erroring return values.
mapD :: (a -> D b) -> [a] -> D [b]
mapD :: (a -> D b) -> [a] -> D [b]
mapD a -> D b
f [a]
xs =
  let handler :: a -> D [b]
handler 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
>>= (\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` (\DocxError
_ -> [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 NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"sdt" Element
element
  , Just Element
sdtContent <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"sdtContent" Element
element
  = (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 Text
"w" Text
"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 NameSpaces
ns (Elem 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 NameSpaces
_ Content
content = [Content
content]

walkDocument :: NameSpaces -> Element -> Element
walkDocument :: NameSpaces -> Element -> Element
walkDocument NameSpaces
ns 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

--                                 ilvl    startOverride   lvl
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

--                 ilvl   format string  start
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 | InFootnote | 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 Comments = Comments 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 ParIndentation = ParIndentation { ParIndentation -> Maybe Integer
leftParIndent    :: Maybe Integer
                                     , ParIndentation -> Maybe Integer
rightParIndent   :: Maybe Integer
                                     , ParIndentation -> Maybe Integer
hangingParIndent :: Maybe Integer}
                      deriving Int -> ParIndentation -> ShowS
[ParIndentation] -> ShowS
ParIndentation -> FilePath
(Int -> ParIndentation -> ShowS)
-> (ParIndentation -> FilePath)
-> ([ParIndentation] -> ShowS)
-> Show ParIndentation
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ParIndentation] -> ShowS
$cshowList :: [ParIndentation] -> ShowS
show :: ParIndentation -> FilePath
$cshow :: ParIndentation -> FilePath
showsPrec :: Int -> ParIndentation -> ShowS
$cshowsPrec :: Int -> ParIndentation -> 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]
              | 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}

newtype Row = Row [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

newtype Cell = Cell [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

leftBiasedMergeRunStyle :: RunStyle -> RunStyle -> RunStyle
leftBiasedMergeRunStyle :: RunStyle -> RunStyle -> RunStyle
leftBiasedMergeRunStyle RunStyle
a 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
    }

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

data ParPart = PlainRun Run
             | ChangedRuns TrackedChange [Run]
             | CommentStart CommentId Author (Maybe CommentDate) [BodyPart]
             | CommentEnd CommentId
             | BookMark BookMarkId Anchor
             | InternalHyperLink Anchor [Run]
             | ExternalHyperLink URL [Run]
             | Drawing FilePath T.Text T.Text B.ByteString Extent -- title, alt
             | Chart                                              -- placeholder for now
             | PlainOMath [Exp]
             | Field FieldInfo [Run]
             | NullParPart      -- when we need to return nothing, but
                                -- not because of an error.
             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]
         | Footnote [BodyPart]
         | Endnote [BodyPart]
         | InlineDrawing FilePath T.Text T.Text B.ByteString Extent -- title, alt
         | InlineChart          -- placeholder
           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 CommentId = T.Text
type Author = T.Text
type ChangeDate = T.Text
type CommentDate = T.Text

archiveToDocx :: Archive -> Either DocxError Docx
archiveToDocx :: Archive -> Either DocxError Docx
archiveToDocx Archive
archive = (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 = do
  FilePath
docXmlPath <- case Archive -> Maybe FilePath
getDocumentXmlPath Archive
archive of
    Just FilePath
fp -> FilePath -> Either DocxError FilePath
forall a b. b -> Either a b
Right FilePath
fp
    Maybe FilePath
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
      (CharStyleMap
styles, 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 = FldCharState
FldCharClosed
                           }
      (Either DocxError Document
eitherDoc, 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 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 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 =
  case Text -> Either Text Element
parseXMLElement (ByteString -> Text
UTF8.toTextLazy (Entry -> ByteString
fromEntry Entry
entry)) of
    Left Text
_   -> Maybe Element
forall a. Maybe a
Nothing
    Right Element
el -> Element -> Maybe Element
forall a. a -> Maybe a
Just Element
el

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

archiveToDocument :: Archive -> D Document
archiveToDocument :: Archive -> D Document
archiveToDocument 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 Text
"w" Text
"body" Element
docElem
  let bodyElem' :: Element
bodyElem' = NameSpaces -> Element -> Element
walkDocument NameSpaces
namespaces Element
bodyElem
  Body
body <- NameSpaces -> Element -> D Body
elemToBody NameSpaces
namespaces Element
bodyElem'
  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 NameSpaces
ns Element
element | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"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 NameSpaces
_ Element
_ = 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 ParaStyleName
stName = ParStyle :: Maybe (ParaStyleName, Int)
-> Maybe (Text, Text)
-> Maybe ParStyle
-> ParaStyleName
-> ParaStyleId
-> ParStyle
ParStyle
  { headingLev :: Maybe (ParaStyleName, Int)
headingLev = Maybe (ParaStyleName, Int)
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
/=Char
' ') (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 Archive
zf =
  let fnElem :: Maybe Element
fnElem = FilePath -> Archive -> Maybe Entry
findEntryByPath FilePath
"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 FilePath
"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 Text
"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 Text
"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
archiveToComments :: Archive -> Comments
archiveToComments Archive
zf =
  let cmtsElem :: Maybe Element
cmtsElem = FilePath -> Archive -> Maybe Entry
findEntryByPath FilePath
"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 Map Text Element
c  -> NameSpaces -> Map Text Element -> Comments
Comments NameSpaces
cmts_namespaces Map Text Element
c
      Maybe (Map Text Element)
Nothing -> NameSpaces -> Map Text Element -> Comments
Comments NameSpaces
cmts_namespaces Map Text Element
forall k a. Map k a
M.empty

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

relElemToRelationship :: DocumentLocation -> Element -> Maybe Relationship
relElemToRelationship :: DocumentLocation -> Element -> Maybe Relationship
relElemToRelationship DocumentLocation
relType Element
element | QName -> Text
qName (Element -> QName
elName Element
element) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Relationship" =
  do
    Text
relId <- QName -> Element -> Maybe Text
findAttr (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"Id" 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 Text
"Target" Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing) Element
element
    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 DocumentLocation
_ Element
_ = Maybe Relationship
forall a. Maybe a
Nothing

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

archiveToRelationships :: Archive -> FilePath -> [Relationship]
archiveToRelationships :: Archive -> FilePath -> [Relationship]
archiveToRelationships Archive
archive 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 FilePath
fp =
  let (FilePath
dir, FilePath
_) = FilePath -> (FilePath, FilePath)
splitFileName FilePath
fp
  in
   (FilePath
dir FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"word/media/")

lookupLevel :: T.Text -> T.Text -> Numbering -> Maybe Level
lookupLevel :: Text -> Text -> Numbering -> Maybe Level
lookupLevel Text
numId Text
ilvl (Numbering NameSpaces
_ [Numb]
numbs [AbstractNumb]
absNumbs) = do
  (Text
absNumId, [LevelOverride]
ovrrides) <- 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 Text
nid Text
absnumid [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 Text
aid [Level]
ls) -> (Text
aid, [Level]
ls)) [AbstractNumb]
absNumbs
  -- this can be a maybe, so we do a let
  let lvlOverride :: Maybe LevelOverride
lvlOverride = 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 Text
ilvl' Maybe Integer
_ Maybe Level
_) -> (Text
ilvl', LevelOverride
lo)) [LevelOverride]
ovrrides
  case Maybe LevelOverride
lvlOverride of
    Just (LevelOverride Text
_ Maybe Integer
_ (Just Level
lvl')) -> Level -> Maybe Level
forall a. a -> Maybe a
Just Level
lvl'
    Just (LevelOverride Text
_ (Just Integer
strt) Maybe Level
_) ->
      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 Text
i Text
fmt Text
s Maybe Integer
_) -> (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
    Maybe LevelOverride
_ ->
      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 Text
i Text
_ Text
_ Maybe Integer
_) -> (Text
i, Level
l)) [Level]
lvls

loElemToLevelOverride :: NameSpaces -> Element -> Maybe LevelOverride
loElemToLevelOverride :: NameSpaces -> Element -> Maybe LevelOverride
loElemToLevelOverride NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"lvlOverride" Element
element = do
      Text
ilvl <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"ilvl" Element
element
      let startOverride :: Maybe Integer
startOverride = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"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 Text
"w" Text
"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 Text
"w" Text
"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 NameSpaces
_ Element
_ = Maybe LevelOverride
forall a. Maybe a
Nothing

numElemToNum :: NameSpaces -> Element -> Maybe Numb
numElemToNum :: NameSpaces -> Element -> Maybe Numb
numElemToNum NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"num" Element
element = do
      Text
numId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"numId" Element
element
      Text
absNumId <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"abstractNumId" Element
element
                  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 Text
"w" Text
"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 Text
"w" Text
"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 NameSpaces
_ Element
_ = Maybe Numb
forall a. Maybe a
Nothing

absNumElemToAbsNum :: NameSpaces -> Element -> Maybe AbstractNumb
absNumElemToAbsNum :: NameSpaces -> Element -> Maybe AbstractNumb
absNumElemToAbsNum NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"abstractNum" Element
element = do
      Text
absNumId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"abstractNumId" Element
element
      let levelElems :: [Element]
levelElems = NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns Text
"w" Text
"lvl" Element
element
          levels :: [Level]
levels = (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 NameSpaces
_ Element
_ = Maybe AbstractNumb
forall a. Maybe a
Nothing

levelElemToLevel :: NameSpaces -> Element -> Maybe Level
levelElemToLevel :: NameSpaces -> Element -> Maybe Level
levelElemToLevel NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"lvl" Element
element = do
      Text
ilvl <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"ilvl" Element
element
      Text
fmt <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"numFmt" Element
element
             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 Text
"w" Text
"val"
      Text
txt <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"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 Text
"w" Text
"val"
      let start :: Maybe Integer
start = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"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 Text
"w" Text
"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 NameSpaces
_ Element
_ = Maybe Level
forall a. Maybe a
Nothing

archiveToNumbering' :: Archive -> Maybe Numbering
archiveToNumbering' :: Archive -> Maybe Numbering
archiveToNumbering' Archive
zf =
  case FilePath -> Archive -> Maybe Entry
findEntryByPath FilePath
"word/numbering.xml" Archive
zf of
    Maybe Entry
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 -> do
      Element
numberingElem <- Entry -> Maybe Element
parseXMLFromEntry Entry
entry
      let namespaces :: NameSpaces
namespaces = Element -> NameSpaces
elemToNameSpaces Element
numberingElem
          numElems :: [Element]
numElems = NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
namespaces Text
"w" Text
"num" Element
numberingElem
          absNumElems :: [Element]
absNumElems = NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
namespaces Text
"w" Text
"abstractNum" Element
numberingElem
          nums :: [Numb]
nums = (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 =
  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 NameSpaces
ns Text
notetype Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" (Text
notetype Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"s") Element
element =
      let pairs :: [(Text, Element)]
pairs = (Element -> Maybe (Text, Element))
-> [Element] -> [(Text, Element)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                  (\Element
e -> NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
e Maybe Text
-> (Text -> Maybe (Text, Element)) -> Maybe (Text, Element)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                         (\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 Text
"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 NameSpaces
_ Text
_ Element
_ = Maybe (Map Text Element)
forall a. Maybe a
Nothing

elemToComments :: NameSpaces -> Element -> M.Map T.Text Element
elemToComments :: NameSpaces -> Element -> Map Text Element
elemToComments NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"comments" Element
element =
      let pairs :: [(Text, Element)]
pairs = (Element -> Maybe (Text, Element))
-> [Element] -> [(Text, Element)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                  (\Element
e -> NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
e Maybe Text
-> (Text -> Maybe (Text, Element)) -> Maybe (Text, Element)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                         (\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 Text
"w" Text
"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 NameSpaces
_ Element
_ = Map Text Element
forall k a. Map k a
M.empty


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

elemToTblGrid :: NameSpaces -> Element -> D TblGrid
elemToTblGrid :: NameSpaces -> Element -> D TblGrid
elemToTblGrid NameSpaces
ns Element
element | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"tblGrid" Element
element =
  let cols :: [Element]
cols = NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns Text
"w" Text
"gridCol" Element
element
  in
   (Element -> D Integer) -> [Element] -> D TblGrid
forall a b. (a -> D b) -> [a] -> D [b]
mapD (\Element
e -> Maybe Integer -> D Integer
forall a. Maybe a -> D a
maybeToD (NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"val" 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 NameSpaces
_ Element
_ = 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 NameSpaces
ns Element
element | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"tblLook" Element
element =
  let firstRow :: Maybe Text
firstRow = NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"firstRow" Element
element
      val :: Maybe Text
val = NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"val" Element
element
      firstRowFmt :: Bool
firstRowFmt =
        case Maybe Text
firstRow of
          Just Text
"1" -> Bool
True
          Just  Text
_  -> Bool
False
          Maybe Text
Nothing -> case Maybe Text
val of
            Just Text
bitMask -> Text -> Int -> Bool
testBitMask Text
bitMask Int
0x020
            Maybe Text
Nothing      -> Bool
False
  in
   TblLook -> D TblLook
forall (m :: * -> *) a. Monad m => a -> m a
return TblLook :: Bool -> TblLook
TblLook{firstRowFormatting :: Bool
firstRowFormatting = Bool
firstRowFmt}
elemToTblLook NameSpaces
_ Element
_ = 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 NameSpaces
ns Element
element | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"tr" Element
element =
  do
    let cellElems :: [Element]
cellElems = NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns Text
"w" Text
"tc" Element
element
    [Cell]
cells <- (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
    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
$ [Cell] -> Row
Row [Cell]
cells
elemToRow NameSpaces
_ Element
_ = 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 NameSpaces
ns Element
element | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"tc" Element
element =
  do
    [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
$ [BodyPart] -> Cell
Cell [BodyPart]
cellContents
elemToCell NameSpaces
_ Element
_ = DocxError -> D Cell
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem

elemToParIndentation :: NameSpaces -> Element -> Maybe ParIndentation
elemToParIndentation :: NameSpaces -> Element -> Maybe ParIndentation
elemToParIndentation NameSpaces
ns Element
element | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"ind" Element
element =
 ParIndentation -> Maybe ParIndentation
forall a. a -> Maybe a
Just ParIndentation :: Maybe Integer -> Maybe Integer -> Maybe Integer -> ParIndentation
ParIndentation {
    leftParIndent :: Maybe Integer
leftParIndent =
       NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"left" Element
element Maybe Text -> (Text -> Maybe Integer) -> Maybe Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
       Text -> Maybe Integer
stringToInteger
    , rightParIndent :: Maybe Integer
rightParIndent =
      NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"right" Element
element Maybe Text -> (Text -> Maybe Integer) -> Maybe Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      Text -> Maybe Integer
stringToInteger
    , hangingParIndent :: Maybe Integer
hangingParIndent =
      NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"hanging" Element
element Maybe Text -> (Text -> Maybe Integer) -> Maybe Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      Text -> Maybe Integer
stringToInteger }
elemToParIndentation NameSpaces
_ Element
_ = Maybe ParIndentation
forall a. Maybe a
Nothing

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

elemToBodyPart :: NameSpaces -> Element -> D BodyPart
elemToBodyPart :: NameSpaces -> Element -> D BodyPart
elemToBodyPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"p" Element
element
  , (Element
c:[Element]
_) <- NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns Text
"m" Text
"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 NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"p" Element
element
  , Just (Text
numId, Text
lvl) <- NameSpaces -> Element -> Maybe (Text, Text)
getNumInfo NameSpaces
ns Element
element = do
    ParagraphStyle
parstyle <- NameSpaces -> Element -> ParStyleMap -> 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 <- (Element -> D ParPart) -> [Element] -> D [ParPart]
forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D 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 NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"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 <- (Element -> D ParPart) -> [Element] -> D [ParPart]
forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D ParPart
elemToParPart NameSpaces
ns) (Element -> [Element]
elChildren Element
element)
      -- Word uses list enumeration for numbered headings, so we only
      -- want to infer a list from the styles if it is NOT a heading.
      case ParagraphStyle -> Maybe (ParaStyleName, Int)
pHeading ParagraphStyle
parstyle of
        Maybe (ParaStyleName, Int)
Nothing | Just (Text
numId, Text
lvl) <- ParagraphStyle -> Maybe (Text, Text)
pNumInfo ParagraphStyle
parstyle -> do
                    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
        Maybe (ParaStyleName, Int)
_ -> 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 NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"tbl" Element
element = do
    let caption' :: Maybe Text
caption' = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"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 Text
"w" Text
"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 Text
"w" Text
"val"
        caption :: Text
caption = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
caption'
        grid' :: D TblGrid
grid' = case NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"tblGrid" Element
element of
          Just Element
g  -> NameSpaces -> Element -> D TblGrid
elemToTblGrid NameSpaces
ns Element
g
          Maybe Element
Nothing -> 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 Text
"w" Text
"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 Text
"w" Text
"tblLook"
                     of
                       Just Element
l  -> NameSpaces -> Element -> D TblLook
elemToTblLook NameSpaces
ns Element
l
                       Maybe Element
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 TblGrid
grid TblLook
tblLook [Row]
rows
elemToBodyPart NameSpaces
_ Element
_ = 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 DocumentLocation
docLocation Text
relid [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 DocumentLocation
loc Text
relid' Text
target) -> ((DocumentLocation
loc, Text
relid'), Text
target)) [Relationship]
rels

expandDrawingId :: T.Text -> D (FilePath, B.ByteString)
expandDrawingId :: Text -> D (FilePath, ByteString)
expandDrawingId 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 -> do
      Maybe ByteString
bytes <- (ReaderEnv -> Maybe ByteString)
-> ExceptT
     DocxError
     (ReaderT ReaderEnv (State ReaderState))
     (Maybe ByteString)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (FilePath -> Media -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (FilePath
"word/" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
filepath) (Media -> Maybe ByteString)
-> (ReaderEnv -> Media) -> ReaderEnv -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderEnv -> Media
envMedia)
      case Maybe ByteString
bytes of
        Just ByteString
bs -> (FilePath, ByteString) -> D (FilePath, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
filepath, ByteString
bs)
        Maybe ByteString
Nothing -> DocxError -> D (FilePath, ByteString)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
DocxError
    Maybe FilePath
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 NameSpaces
ns Element
element =
  let mbDocPr :: Maybe Element
mbDocPr = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"wp" Text
"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 Text
"wp" Text
"docPr"
      title :: Text
title = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (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 Text
"" Text
"title")
      alt :: Text
alt = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (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 Text
"" Text
"descr")
  in (Text
title, Text
alt)

elemToParPart :: NameSpaces -> Element -> D ParPart
elemToParPart :: NameSpaces -> Element -> D ParPart
elemToParPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
drawingElem <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"drawing" Element
element
  , Text
pic_ns <- Text
"http://schemas.openxmlformats.org/drawingml/2006/picture"
  , Just Element
picElem <- QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"pic" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
pic_ns) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"pic")) Element
drawingElem
  = let (Text
title, Text
alt) = NameSpaces -> Element -> (Text, Text)
getTitleAndAlt NameSpaces
ns Element
drawingElem
        a_ns :: Text
a_ns = Text
"http://schemas.openxmlformats.org/drawingml/2006/main"
        drawing :: Maybe Text
drawing = QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"blip" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
a_ns) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"a")) Element
picElem
                  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 Text
"r" Text
"embed"
    in
     case Maybe Text
drawing of
       Just Text
s -> Text -> D (FilePath, ByteString)
expandDrawingId Text
s D (FilePath, ByteString)
-> ((FilePath, ByteString) -> D ParPart) -> D ParPart
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(FilePath
fp, ByteString
bs) -> ParPart -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return (ParPart -> D ParPart) -> ParPart -> D ParPart
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> Text -> ByteString -> Extent -> ParPart
Drawing FilePath
fp Text
title Text
alt ByteString
bs (Extent -> ParPart) -> Extent -> ParPart
forall a b. (a -> b) -> a -> b
$ Element -> Extent
elemToExtent Element
drawingElem)
       Maybe Text
Nothing -> DocxError -> D ParPart
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
-- The below is an attempt to deal with images in deprecated vml format.
elemToParPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
_ <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"pict" Element
element =
    let drawing :: Maybe Text
drawing = QName -> Element -> Maybe Element
findElement (NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns Text
"v" Text
"imagedata") Element
element
                  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 Text
"r" Text
"id"
    in
     case Maybe Text
drawing of
       -- Todo: check out title and attr for deprecated format.
       Just Text
s -> Text -> D (FilePath, ByteString)
expandDrawingId Text
s D (FilePath, ByteString)
-> ((FilePath, ByteString) -> D ParPart) -> D ParPart
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(FilePath
fp, ByteString
bs) -> ParPart -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return (ParPart -> D ParPart) -> ParPart -> D ParPart
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> Text -> ByteString -> Extent -> ParPart
Drawing FilePath
fp Text
"" Text
"" ByteString
bs Extent
forall a. Maybe a
Nothing)
       Maybe Text
Nothing -> DocxError -> D ParPart
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
-- Chart
elemToParPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
drawingElem <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"drawing" Element
element
  , Text
c_ns <- Text
"http://schemas.openxmlformats.org/drawingml/2006/chart"
  , Just Element
_ <- QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"chart" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
c_ns) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"c")) Element
drawingElem
  = ParPart -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return ParPart
Chart
{-
The next one is a bit complicated. fldChar fields work by first
having a <w:fldChar fldCharType="begin"> in a run, then a run with
<w:instrText>, then a <w:fldChar fldCharType="separate"> run, then the
content runs, and finally a <w:fldChar fldCharType="end"> run. For
example (omissions and my comments in brackets):

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

So we do this in a number of steps. If we encounter the fldchar begin
tag, we start open a fldchar state variable (see state above). We add
the instrtext to it as FieldInfo. Then we close that and start adding
the runs when we get to separate. Then when we get to end, we produce
the Field type with appropriate FieldInfo and Runs.
-}
elemToParPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
fldChar <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"fldChar" Element
element
  , Just Text
fldCharType <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"fldCharType" Element
fldChar = do
      FldCharState
fldCharState <- (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
        FldCharState
FldCharClosed | Text
fldCharType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"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
$ \ReaderState
st -> ReaderState
st {stateFldCharState :: FldCharState
stateFldCharState = FldCharState
FldCharOpen}
          ParPart -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return ParPart
NullParPart
        FldCharFieldInfo FieldInfo
info | Text
fldCharType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"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
$ \ReaderState
st -> ReaderState
st {stateFldCharState :: FldCharState
stateFldCharState = FieldInfo -> [Run] -> FldCharState
FldCharContent FieldInfo
info []}
          ParPart -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return ParPart
NullParPart
        FldCharContent FieldInfo
info [Run]
runs | Text
fldCharType Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"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
$ \ReaderState
st -> ReaderState
st {stateFldCharState :: FldCharState
stateFldCharState = FldCharState
FldCharClosed}
          ParPart -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return (ParPart -> D ParPart) -> ParPart -> D ParPart
forall a b. (a -> b) -> a -> b
$ FieldInfo -> [Run] -> ParPart
Field FieldInfo
info ([Run] -> ParPart) -> [Run] -> ParPart
forall a b. (a -> b) -> a -> b
$ [Run] -> [Run]
forall a. [a] -> [a]
reverse [Run]
runs
        FldCharState
_ -> DocxError -> D ParPart
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
elemToParPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
instrText <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"instrText" Element
element = do
      FldCharState
fldCharState <- (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
        FldCharState
FldCharOpen -> 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
$ \ReaderState
st -> ReaderState
st{stateFldCharState :: FldCharState
stateFldCharState = FieldInfo -> FldCharState
FldCharFieldInfo FieldInfo
info}
          ParPart -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return ParPart
NullParPart
        FldCharState
_ -> ParPart -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return ParPart
NullParPart
elemToParPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element = do
    Run
run <- NameSpaces -> Element -> D Run
elemToRun NameSpaces
ns Element
element
    -- we check to see if we have an open FldChar in state that we're
    -- recording.
    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 FieldInfo
info [Run]
runs -> 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
$ \ReaderState
st -> ReaderState
st{stateFldCharState :: FldCharState
stateFldCharState = FieldInfo -> [Run] -> FldCharState
FldCharContent FieldInfo
info (Run
run Run -> [Run] -> [Run]
forall a. a -> [a] -> [a]
: [Run]
runs)}
        ParPart -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return ParPart
NullParPart
      FldCharState
_ -> ParPart -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return (ParPart -> D ParPart) -> ParPart -> D ParPart
forall a b. (a -> b) -> a -> b
$ Run -> ParPart
PlainRun Run
run
elemToParPart NameSpaces
ns Element
element
  | Just TrackedChange
change <- NameSpaces -> Element -> Maybe TrackedChange
getTrackedChange NameSpaces
ns Element
element = do
      [Run]
runs <- (Element -> D Run) -> [Element] -> D [Run]
forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D Run
elemToRun NameSpaces
ns) (Element -> [Element]
elChildren Element
element)
      ParPart -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return (ParPart -> D ParPart) -> ParPart -> D ParPart
forall a b. (a -> b) -> a -> b
$ TrackedChange -> [Run] -> ParPart
ChangedRuns TrackedChange
change [Run]
runs
elemToParPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"bookmarkStart" Element
element
  , Just Text
bmId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
element
  , Just Text
bmName <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"name" Element
element =
    ParPart -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return (ParPart -> D ParPart) -> ParPart -> D ParPart
forall a b. (a -> b) -> a -> b
$ Text -> Text -> ParPart
BookMark Text
bmId Text
bmName
elemToParPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"hyperlink" Element
element
  , Just Text
relId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"r" Text
"id" Element
element = do
    DocumentLocation
location <- (ReaderEnv -> DocumentLocation)
-> ExceptT
     DocxError (ReaderT ReaderEnv (State ReaderState)) DocumentLocation
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ReaderEnv -> DocumentLocation
envLocation
    [Run]
runs <- (Element -> D Run) -> [Element] -> D [Run]
forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D Run
elemToRun 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 Text
target ->
         case NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"anchor" Element
element of
             Just Text
anchor -> ParPart -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return (ParPart -> D ParPart) -> ParPart -> D ParPart
forall a b. (a -> b) -> a -> b
$ Text -> [Run] -> ParPart
ExternalHyperLink (Text
target Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
anchor) [Run]
runs
             Maybe Text
Nothing -> ParPart -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return (ParPart -> D ParPart) -> ParPart -> D ParPart
forall a b. (a -> b) -> a -> b
$ Text -> [Run] -> ParPart
ExternalHyperLink Text
target [Run]
runs
      Maybe Text
Nothing     -> ParPart -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return (ParPart -> D ParPart) -> ParPart -> D ParPart
forall a b. (a -> b) -> a -> b
$ Text -> [Run] -> ParPart
ExternalHyperLink Text
"" [Run]
runs
elemToParPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"hyperlink" Element
element
  , Just Text
anchor <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"anchor" Element
element = do
    [Run]
runs <- (Element -> D Run) -> [Element] -> D [Run]
forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D Run
elemToRun NameSpaces
ns) (Element -> [Element]
elChildren Element
element)
    ParPart -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return (ParPart -> D ParPart) -> ParPart -> D ParPart
forall a b. (a -> b) -> a -> b
$ Text -> [Run] -> ParPart
InternalHyperLink Text
anchor [Run]
runs
elemToParPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"commentRangeStart" Element
element
  , Just Text
cmtId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
element = do
      (Comments NameSpaces
_ Map Text Element
commentMap) <- (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 Element
cmtElem -> NameSpaces -> Element -> D ParPart
elemToCommentStart NameSpaces
ns Element
cmtElem
        Maybe Element
Nothing      -> DocxError -> D ParPart
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
elemToParPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"commentRangeEnd" Element
element
  , Just Text
cmtId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
element =
    ParPart -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return (ParPart -> D ParPart) -> ParPart -> D ParPart
forall a b. (a -> b) -> a -> b
$ Text -> ParPart
CommentEnd Text
cmtId
elemToParPart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"m" Text
"oMath" Element
element =
    ([Exp] -> ParPart) -> D [Exp] -> D ParPart
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [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 NameSpaces
_ Element
_ = DocxError -> D ParPart
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem

elemToCommentStart :: NameSpaces -> Element -> D ParPart
elemToCommentStart :: NameSpaces -> Element -> D ParPart
elemToCommentStart NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"comment" Element
element
  , Just Text
cmtId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
element
  , Just Text
cmtAuthor <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"author" Element
element
  , Maybe Text
cmtDate <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"date" Element
element = do
      [BodyPart]
bps <- (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 -> D ParPart
forall (m :: * -> *) a. Monad m => a -> m a
return (ParPart -> D ParPart) -> ParPart -> D ParPart
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text -> [BodyPart] -> ParPart
CommentStart Text
cmtId Text
cmtAuthor Maybe Text
cmtDate [BodyPart]
bps
elemToCommentStart NameSpaces
_ Element
_ = DocxError -> D ParPart
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem

lookupFootnote :: T.Text -> Notes -> Maybe Element
lookupFootnote :: Text -> Notes -> Maybe Element
lookupFootnote Text
s (Notes NameSpaces
_ Maybe (Map Text Element)
fns Maybe (Map Text Element)
_) = Maybe (Map Text Element)
fns 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 Text
s (Notes NameSpaces
_ Maybe (Map Text Element)
_ 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 -> Extent
elemToExtent Element
drawingElem =
  case (Text -> Maybe Double
forall b. Read b => Text -> Maybe b
getDim Text
"cx", Text -> Maybe Double
forall b. Read b => Text -> Maybe b
getDim Text
"cy") of
    (Just Double
w, Just Double
h) -> (Double, Double) -> Extent
forall a. a -> Maybe a
Just (Double
w, Double
h)
    (Maybe Double, Maybe Double)
_                -> Extent
forall a. Maybe a
Nothing
    where
      wp_ns :: Text
wp_ns  = Text
"http://schemas.openxmlformats.org/drawingml/2006/wordprocessingDrawing"
      getDim :: Text -> Maybe b
getDim Text
at = QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"extent" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
wp_ns) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"wp")) Element
drawingElem
                    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 NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"drawing" Element
element
  , Text
pic_ns <- Text
"http://schemas.openxmlformats.org/drawingml/2006/picture"
  , Just Element
picElem <- QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"pic" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
pic_ns) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"pic")) Element
element
  = let (Text
title, Text
alt) = NameSpaces -> Element -> (Text, Text)
getTitleAndAlt NameSpaces
ns Element
element
        a_ns :: Text
a_ns = Text
"http://schemas.openxmlformats.org/drawingml/2006/main"
        drawing :: Maybe Text
drawing = QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"blip" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
a_ns) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"a")) Element
picElem
                  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
"embed" (Text -> NameSpaces -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"r" NameSpaces
ns) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"r"))
    in
     case Maybe Text
drawing of
       Just Text
s -> Text -> D (FilePath, ByteString)
expandDrawingId Text
s D (FilePath, ByteString)
-> ((FilePath, ByteString) -> D Run) -> D Run
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                 (\(FilePath
fp, ByteString
bs) -> Run -> D Run
forall (m :: * -> *) a. Monad m => a -> m a
return (Run -> D Run) -> Run -> D Run
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> Text -> ByteString -> Extent -> Run
InlineDrawing FilePath
fp Text
title Text
alt ByteString
bs (Extent -> Run) -> Extent -> Run
forall a b. (a -> b) -> a -> b
$ Element -> Extent
elemToExtent Element
element)
       Maybe Text
Nothing -> DocxError -> D Run
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DocxError
WrongElem
childElemToRun NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"drawing" Element
element
  , Text
c_ns <- Text
"http://schemas.openxmlformats.org/drawingml/2006/chart"
  , Just Element
_ <- QName -> Element -> Maybe Element
findElement (Text -> Maybe Text -> Maybe Text -> QName
QName Text
"chart" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
c_ns) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"c")) Element
element
  = Run -> D Run
forall (m :: * -> *) a. Monad m => a -> m a
return Run
InlineChart
childElemToRun NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"footnoteReference" Element
element
  , Just Text
fnId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"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 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 (\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 (Run -> D Run) -> Run -> D Run
forall a b. (a -> b) -> a -> b
$ [BodyPart] -> Run
Footnote [BodyPart]
bps
      Maybe Element
Nothing  -> Run -> D Run
forall (m :: * -> *) a. Monad m => a -> m a
return (Run -> D Run) -> Run -> D Run
forall a b. (a -> b) -> a -> b
$ [BodyPart] -> Run
Footnote []
childElemToRun NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"endnoteReference" Element
element
  , Just Text
enId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
element = do
    Notes
notes <- (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 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 (\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 (Run -> D Run) -> Run -> D Run
forall a b. (a -> b) -> a -> b
$ [BodyPart] -> Run
Endnote [BodyPart]
bps
      Maybe Element
Nothing  -> Run -> D Run
forall (m :: * -> *) a. Monad m => a -> m a
return (Run -> D Run) -> Run -> D Run
forall a b. (a -> b) -> a -> b
$ [BodyPart] -> Run
Endnote []
childElemToRun NameSpaces
_ Element
_ = 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 NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
altCont <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"mc" Text
"AlternateContent" Element
element =
    do let choices :: [Element]
choices = NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns Text
"mc" Text
"Choice" Element
altCont
           choiceChildren :: [Element]
choiceChildren = ([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] -> D [Run]
forall a b. (a -> D b) -> [a] -> D [b]
mapD (NameSpaces -> Element -> D Run
childElemToRun NameSpaces
ns) [Element]
choiceChildren
       case [Run]
outputs of
         Run
r : [Run]
_ -> 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 NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
drawingElem <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"drawing" Element
element =
    NameSpaces -> Element -> D Run
childElemToRun NameSpaces
ns Element
drawingElem
elemToRun NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
ref <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"footnoteReference" Element
element =
    NameSpaces -> Element -> D Run
childElemToRun NameSpaces
ns Element
ref
elemToRun NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
  , Just Element
ref <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"endnoteReference" Element
element =
    NameSpaces -> Element -> D Run
childElemToRun NameSpaces
ns Element
ref
elemToRun NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element = do
    [RunElem]
runElems <- NameSpaces -> Element -> D [RunElem]
elemToRunElems NameSpaces
ns Element
element
    RunStyle
runStyle <- NameSpaces -> Element -> D RunStyle
elemToRunStyleD NameSpaces
ns Element
element
    Run -> D Run
forall (m :: * -> *) a. Monad m => a -> m a
return (Run -> D Run) -> Run -> D Run
forall a b. (a -> b) -> a -> b
$ RunStyle -> [RunElem] -> Run
Run RunStyle
runStyle [RunElem]
runElems
elemToRun NameSpaces
_ Element
_ = 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 ParStyle -> Maybe a
field ParStyle
style
  | Just a
value <- ParStyle -> Maybe a
field ParStyle
style = a -> Maybe a
forall a. a -> Maybe a
Just a
value
  | Just 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 ParStyle -> Maybe a
_ ParStyle
_ = Maybe a
forall a. Maybe a
Nothing

getParStyleField :: (ParStyle -> Maybe a) -> [ParStyle] -> Maybe a
getParStyleField :: (ParStyle -> Maybe a) -> [ParStyle] -> Maybe a
getParStyleField ParStyle -> Maybe a
field [ParStyle]
styles
  | (a
y:[a]
_) <- (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 ParStyle -> Maybe a
_ [ParStyle]
_ = Maybe a
forall a. Maybe a
Nothing

getTrackedChange :: NameSpaces -> Element -> Maybe TrackedChange
getTrackedChange :: NameSpaces -> Element -> Maybe TrackedChange
getTrackedChange NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"ins" Element
element Bool -> Bool -> Bool
|| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"moveTo" Element
element
  , Just Text
cId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
element
  , Just Text
cAuthor <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"author" Element
element
  , Maybe Text
mcDate <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"date" Element
element =
      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 NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"del" Element
element Bool -> Bool -> Bool
|| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"moveFrom" Element
element
  , Just Text
cId <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"id" Element
element
  , Just Text
cAuthor <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"author" Element
element
  , Maybe Text
mcDate <- NameSpaces -> Text -> Text -> Element -> Maybe Text
findAttrByName NameSpaces
ns Text
"w" Text
"date" Element
element =
      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 NameSpaces
_ Element
_ = Maybe TrackedChange
forall a. Maybe a
Nothing

elemToParagraphStyle :: NameSpaces -> Element -> ParStyleMap -> ParagraphStyle
elemToParagraphStyle :: NameSpaces -> Element -> ParStyleMap -> ParagraphStyle
elemToParagraphStyle NameSpaces
ns Element
element ParStyleMap
sty
  | Just Element
pPr <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"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 Text
"w" Text
"val")
          (NameSpaces -> Text -> Text -> Element -> [Element]
findChildrenByName NameSpaces
ns Text
"w" Text
"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 -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"ind" Element
pPr Maybe Element
-> (Element -> Maybe ParIndentation) -> Maybe ParIndentation
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
          NameSpaces -> Element -> Maybe ParIndentation
elemToParIndentation NameSpaces
ns
      , dropCap :: Bool
dropCap =
          case
            NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"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 Text
"w" Text
"dropCap"
          of
            Just Text
"none" -> Bool
False
            Just Text
_      -> Bool
True
            Maybe Text
Nothing     -> Bool
False
      , pChange :: Maybe TrackedChange
pChange     = NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"rPr" Element
pPr 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 (\Element
e -> NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"ins" Element
e Bool -> Bool -> Bool
||
                                         NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"moveTo" Element
e Bool -> Bool -> Bool
||
                                         NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"del" Element
e Bool -> Bool -> Bool
||
                                         NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"moveFrom" Element
e
                                  ) 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 Text
"w" Text
"bidi")
      }
elemToParagraphStyle NameSpaces
_ Element
_ ParStyleMap
_ =  ParagraphStyle
defaultParagraphStyle

elemToRunStyleD :: NameSpaces -> Element -> D RunStyle
elemToRunStyleD :: NameSpaces -> Element -> D RunStyle
elemToRunStyleD NameSpaces
ns Element
element
  | Just Element
rPr <- NameSpaces -> Text -> Text -> Element -> Maybe Element
findChildByName NameSpaces
ns Text
"w" Text
"rPr" Element
element = do
    CharStyleMap
charStyles <- (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 Text
"w" Text
"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 Text
"w" Text
"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 NameSpaces
_ Element
_ = 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 NameSpaces
ns Element
element
  | NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"t" Element
element
    Bool -> Bool -> Bool
|| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"delText" Element
element
    Bool -> Bool -> Bool
|| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"m" Text
"t" Element
element = do
    let str :: Text
str = Element -> Text
strContent Element
element
    Maybe Font
font <- (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
      Maybe Font
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 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 (\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 Text
"w" Text
"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 Text
"w" Text
"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 Text
"w" Text
"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 Text
"w" Text
"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 Text
"w" Text
"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 Char
'\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 Char
'\xF000'
      | Bool
otherwise = Int -> Char
chr Int
c

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

elemToRunElems :: NameSpaces -> Element -> D [RunElem]
elemToRunElems :: NameSpaces -> Element -> D [RunElem]
elemToRunElems NameSpaces
ns Element
element
  |  NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"w" Text
"r" Element
element
     Bool -> Bool -> Bool
|| NameSpaces -> Text -> Text -> Element -> Bool
isElem NameSpaces
ns Text
"m" Text
"r" Element
element = do
       let qualName :: Text -> QName
qualName = NameSpaces -> Text -> Text -> QName
elemName NameSpaces
ns Text
"w"
       let font :: Maybe Font
font = do
                    Element
fontElem <- QName -> Element -> Maybe Element
findElement (Text -> QName
qualName Text
"rFonts") Element
element
                    Text -> Maybe Font
textToFont (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 [Text
"ascii", Text
"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 NameSpaces
_ Element
_ = 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 Maybe Font
f ReaderEnv
s = ReaderEnv
s{envFont :: Maybe Font
envFont = Maybe Font
f}