{-# LANGUAGE PatternGuards #-} {- Copyright (C) 2014 Jesse Rosenthal This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} {- | Module : Text.Pandoc.Readers.Docx.Parse Copyright : Copyright (C) 2014 Jesse Rosenthal License : GNU GPL, version 2 or above Maintainer : Jesse Rosenthal Stability : alpha Portability : portable Conversion of docx archive into Docx haskell type -} module Text.Pandoc.Readers.Docx.Parse ( Docx(..) , Document(..) , Body(..) , BodyPart(..) , TblLook(..) , ParPart(..) , OMath(..) , OMathElem(..) , Base(..) , TopBottom(..) , AccentStyle(..) , BarStyle(..) , NAryStyle(..) , DelimStyle(..) , GroupStyle(..) , Run(..) , RunElem(..) , Notes , Numbering , Relationship , Media , RunStyle(..) , ParIndentation(..) , ParagraphStyle(..) , Row(..) , Cell(..) , archiveToDocx ) where import Codec.Archive.Zip import Text.XML.Light import Data.Maybe import Data.List import System.FilePath import Data.Bits ((.|.)) import qualified Data.ByteString.Lazy as B import qualified Text.Pandoc.UTF8 as UTF8 import Control.Monad.Reader import qualified Data.Map as M import Text.Pandoc.Compat.Except data ReaderEnv = ReaderEnv { envNotes :: Notes , envNumbering :: Numbering , envRelationships :: [Relationship] , envMedia :: Media } deriving Show data DocxError = DocxError | WrongElem deriving Show instance Error DocxError where noMsg = WrongElem type D = ExceptT DocxError (Reader ReaderEnv) runD :: D a -> ReaderEnv -> Either DocxError a runD dx re = runReader (runExceptT dx ) re maybeToD :: Maybe a -> D a maybeToD (Just a) = return a maybeToD Nothing = throwError DocxError mapD :: (a -> D b) -> [a] -> D [b] mapD _ [] = return [] mapD f (x:xs) = do y <- (f x >>= (\z -> return [z])) `catchError` (\_ -> return []) ys <- mapD f xs return $ y ++ ys type NameSpaces = [(String, String)] data Docx = Docx Document deriving Show data Document = Document NameSpaces Body deriving Show data Body = Body [BodyPart] deriving Show type Media = [(FilePath, B.ByteString)] data Numbering = Numbering NameSpaces [Numb] [AbstractNumb] deriving Show data Numb = Numb String String -- right now, only a key to an abstract num deriving Show data AbstractNumb = AbstractNumb String [Level] deriving Show -- (ilvl, format, string, start) type Level = (String, String, String, Maybe Integer) data Relationship = Relationship (RelId, Target) deriving Show data Notes = Notes NameSpaces (Maybe (M.Map String Element)) (Maybe (M.Map String Element)) deriving Show data ParIndentation = ParIndentation { leftParIndent :: Maybe Integer , rightParIndent :: Maybe Integer , hangingParIndent :: Maybe Integer} deriving Show data ParagraphStyle = ParagraphStyle { pStyle :: [String] , indentation :: Maybe ParIndentation } deriving Show defaultParagraphStyle :: ParagraphStyle defaultParagraphStyle = ParagraphStyle { pStyle = [] , indentation = Nothing } data BodyPart = Paragraph ParagraphStyle [ParPart] | ListItem ParagraphStyle String String Level [ParPart] | Tbl String TblGrid TblLook [Row] | OMathPara OMathParaStyle [OMath] deriving Show type TblGrid = [Integer] data TblLook = TblLook {firstRowFormatting::Bool} deriving Show defaultTblLook :: TblLook defaultTblLook = TblLook{firstRowFormatting = False} data Row = Row [Cell] deriving Show data Cell = Cell [BodyPart] deriving Show data ParPart = PlainRun Run | Insertion ChangeId Author ChangeDate [Run] | Deletion ChangeId Author ChangeDate [Run] | BookMark BookMarkId Anchor | InternalHyperLink Anchor [Run] | ExternalHyperLink URL [Run] | Drawing FilePath B.ByteString | PlainOMath OMath deriving Show data OMath = OMath [OMathElem] deriving Show data OMathElem = Accent AccentStyle Base | Bar BarStyle Base | Box Base | BorderBox Base | Delimiter DelimStyle [Base] | EquationArray [Base] | Fraction [OMathElem] [OMathElem] | Function [OMathElem] Base | Group GroupStyle Base | LowerLimit Base [OMathElem] | UpperLimit Base [OMathElem] | Matrix [[Base]] | NAry NAryStyle [OMathElem] [OMathElem] Base | Phantom Base | Radical [OMathElem] Base | PreSubSuper [OMathElem] [OMathElem] Base | Sub Base [OMathElem] | SubSuper Base [OMathElem] [OMathElem] | Super Base [OMathElem] | OMathRun OMathRunStyle Run deriving Show data Base = Base [OMathElem] deriving Show -- placeholders type OMathParaStyle = [String] data TopBottom = Top | Bottom deriving Show data AccentStyle = AccentStyle { accentChar :: Maybe Char } deriving Show data BarStyle = BarStyle { barPos :: TopBottom} deriving Show data NAryStyle = NAryStyle { nAryChar :: Maybe Char , nAryLimLoc :: LimLoc} deriving Show defaultNAryStyle :: NAryStyle defaultNAryStyle = NAryStyle { nAryChar = Nothing -- integral, in practice , nAryLimLoc = SubSup } data LimLoc = SubSup | UnderOver deriving Show data DelimStyle = DelimStyle { delimBegChar :: Maybe Char , delimSepChar :: Maybe Char , delimEndChar :: Maybe Char} deriving Show defaultDelimStyle :: DelimStyle defaultDelimStyle = DelimStyle { delimBegChar = Nothing , delimSepChar = Nothing , delimEndChar = Nothing } data GroupStyle = GroupStyle { groupChr :: Maybe Char , groupPos :: Maybe TopBottom } deriving Show defaultGroupStyle :: GroupStyle defaultGroupStyle = GroupStyle {groupChr = Nothing, groupPos = Nothing} type OMathRunStyle = [String] data Run = Run RunStyle [RunElem] | Footnote [BodyPart] | Endnote [BodyPart] deriving Show data RunElem = TextRun String | LnBrk | Tab deriving Show data RunStyle = RunStyle { isBold :: Bool , isItalic :: Bool , isSmallCaps :: Bool , isStrike :: Bool , isSuperScript :: Bool , isSubScript :: Bool , rUnderline :: Maybe String , rStyle :: Maybe String } deriving Show defaultRunStyle :: RunStyle defaultRunStyle = RunStyle { isBold = False , isItalic = False , isSmallCaps = False , isStrike = False , isSuperScript = False , isSubScript = False , rUnderline = Nothing , rStyle = Nothing } type Target = String type Anchor = String type URL = String type BookMarkId = String type RelId = String type ChangeId = String type Author = String type ChangeDate = String attrToNSPair :: Attr -> Maybe (String, String) attrToNSPair (Attr (QName s _ (Just "xmlns")) val) = Just (s, val) attrToNSPair _ = Nothing archiveToDocx :: Archive -> Either DocxError Docx archiveToDocx archive = do let notes = archiveToNotes archive numbering = archiveToNumbering archive rels = archiveToRelationships archive media = archiveToMedia archive rEnv = ReaderEnv notes numbering rels media doc <- runD (archiveToDocument archive) rEnv return $ Docx doc archiveToDocument :: Archive -> D Document archiveToDocument zf = do entry <- maybeToD $ findEntryByPath "word/document.xml" zf docElem <- maybeToD $ (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry let namespaces = mapMaybe attrToNSPair (elAttribs docElem) bodyElem <- maybeToD $ findChild (elemName namespaces "w" "body") docElem body <- elemToBody namespaces bodyElem return $ Document namespaces body elemToBody :: NameSpaces -> Element -> D Body elemToBody ns element | isElem ns "w" "body" element = mapD (elemToBodyPart ns) (elChildren element) >>= (\bps -> return $ Body bps) elemToBody _ _ = throwError WrongElem archiveToNotes :: Archive -> Notes archiveToNotes zf = let fnElem = findEntryByPath "word/footnotes.xml" zf >>= (parseXMLDoc . UTF8.toStringLazy . fromEntry) enElem = findEntryByPath "word/endnotes.xml" zf >>= (parseXMLDoc . UTF8.toStringLazy . fromEntry) fn_namespaces = case fnElem of Just e -> mapMaybe attrToNSPair (elAttribs e) Nothing -> [] en_namespaces = case enElem of Just e -> mapMaybe attrToNSPair (elAttribs e) Nothing -> [] ns = unionBy (\x y -> fst x == fst y) fn_namespaces en_namespaces fn = fnElem >>= (elemToNotes ns "footnote") en = enElem >>= (elemToNotes ns "endnote") in Notes ns fn en filePathIsRel :: FilePath -> Bool filePathIsRel fp = let (dir, name) = splitFileName fp in (dir == "word/_rels/") && ((takeExtension name) == ".rels") relElemToRelationship :: Element -> Maybe Relationship relElemToRelationship element | qName (elName element) == "Relationship" = do relId <- findAttr (QName "Id" Nothing Nothing) element target <- findAttr (QName "Target" Nothing Nothing) element return $ Relationship (relId, target) relElemToRelationship _ = Nothing archiveToRelationships :: Archive -> [Relationship] archiveToRelationships archive = let relPaths = filter filePathIsRel (filesInArchive archive) entries = mapMaybe (\f -> findEntryByPath f archive) relPaths relElems = mapMaybe (parseXMLDoc . UTF8.toStringLazy . fromEntry) entries rels = mapMaybe relElemToRelationship $ concatMap elChildren relElems in rels filePathIsMedia :: FilePath -> Bool filePathIsMedia fp = let (dir, _) = splitFileName fp in (dir == "word/media/") getMediaPair :: Archive -> FilePath -> Maybe (FilePath, B.ByteString) getMediaPair zf fp = case findEntryByPath fp zf of Just e -> Just (fp, fromEntry e) Nothing -> Nothing archiveToMedia :: Archive -> Media archiveToMedia zf = mapMaybe (getMediaPair zf) (filter filePathIsMedia (filesInArchive zf)) lookupLevel :: String -> String -> Numbering -> Maybe Level lookupLevel numId ilvl (Numbering _ numbs absNumbs) = do absNumId <- lookup numId $ map (\(Numb nid absnumid) -> (nid, absnumid)) numbs lvls <- lookup absNumId $ map (\(AbstractNumb aid ls) -> (aid, ls)) absNumbs lvl <- lookup ilvl $ map (\l@(i, _, _, _) -> (i, l)) lvls return lvl numElemToNum :: NameSpaces -> Element -> Maybe Numb numElemToNum ns element | qName (elName element) == "num" && qURI (elName element) == (lookup "w" ns) = do numId <- findAttr (QName "numId" (lookup "w" ns) (Just "w")) element absNumId <- findChild (QName "abstractNumId" (lookup "w" ns) (Just "w")) element >>= findAttr (QName "val" (lookup "w" ns) (Just "w")) return $ Numb numId absNumId numElemToNum _ _ = Nothing absNumElemToAbsNum :: NameSpaces -> Element -> Maybe AbstractNumb absNumElemToAbsNum ns element | qName (elName element) == "abstractNum" && qURI (elName element) == (lookup "w" ns) = do absNumId <- findAttr (QName "abstractNumId" (lookup "w" ns) (Just "w")) element let levelElems = findChildren (QName "lvl" (lookup "w" ns) (Just "w")) element levels = mapMaybe (levelElemToLevel ns) levelElems return $ AbstractNumb absNumId levels absNumElemToAbsNum _ _ = Nothing levelElemToLevel :: NameSpaces -> Element -> Maybe Level levelElemToLevel ns element | qName (elName element) == "lvl" && qURI (elName element) == (lookup "w" ns) = do ilvl <- findAttr (QName "ilvl" (lookup "w" ns) (Just "w")) element fmt <- findChild (QName "numFmt" (lookup "w" ns) (Just "w")) element >>= findAttr (QName "val" (lookup "w" ns) (Just "w")) txt <- findChild (QName "lvlText" (lookup "w" ns) (Just "w")) element >>= findAttr (QName "val" (lookup "w" ns) (Just "w")) let start = findChild (QName "start" (lookup "w" ns) (Just "w")) element >>= findAttr (QName "val" (lookup "w" ns) (Just "w")) >>= (\s -> listToMaybe (map fst (reads s :: [(Integer, String)]))) return (ilvl, fmt, txt, start) levelElemToLevel _ _ = Nothing archiveToNumbering' :: Archive -> Maybe Numbering archiveToNumbering' zf = do case findEntryByPath "word/numbering.xml" zf of Nothing -> Just $ Numbering [] [] [] Just entry -> do numberingElem <- (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry let namespaces = mapMaybe attrToNSPair (elAttribs numberingElem) numElems = findChildren (QName "num" (lookup "w" namespaces) (Just "w")) numberingElem absNumElems = findChildren (QName "abstractNum" (lookup "w" namespaces) (Just "w")) numberingElem nums = mapMaybe (numElemToNum namespaces) numElems absNums = mapMaybe (absNumElemToAbsNum namespaces) absNumElems return $ Numbering namespaces nums absNums archiveToNumbering :: Archive -> Numbering archiveToNumbering archive = fromMaybe (Numbering [] [] []) (archiveToNumbering' archive) elemToNotes :: NameSpaces -> String -> Element -> Maybe (M.Map String Element) elemToNotes ns notetype element | isElem ns "w" (notetype ++ "s") element = let pairs = mapMaybe (\e -> findAttr (elemName ns "w" "id") e >>= (\a -> Just (a, e))) (findChildren (elemName ns "w" notetype) element) in Just $ M.fromList $ pairs elemToNotes _ _ _ = Nothing --------------------------------------------- --------------------------------------------- elemName :: NameSpaces -> String -> String -> QName elemName ns prefix name = (QName name (lookup prefix ns) (Just prefix)) isElem :: NameSpaces -> String -> String -> Element -> Bool isElem ns prefix name element = qName (elName element) == name && qURI (elName element) == (lookup prefix ns) elemToTblGrid :: NameSpaces -> Element -> D TblGrid elemToTblGrid ns element | isElem ns "w" "tblGrid" element = let cols = findChildren (elemName ns "w" "gridCol") element in mapD (\e -> maybeToD (findAttr (elemName ns "w" "val") e >>= stringToInteger)) cols elemToTblGrid _ _ = throwError WrongElem elemToTblLook :: NameSpaces -> Element -> D TblLook elemToTblLook ns element | isElem ns "w" "tblLook" element = let firstRow = findAttr (elemName ns "w" "firstRow") element val = findAttr (elemName ns "w" "val") element firstRowFmt = case firstRow of Just "1" -> True Just _ -> False Nothing -> case val of Just bitMask -> testBitMask bitMask 0x020 Nothing -> False in return $ TblLook{firstRowFormatting = firstRowFmt} elemToTblLook _ _ = throwError WrongElem elemToRow :: NameSpaces -> Element -> D Row elemToRow ns element | isElem ns "w" "tr" element = do let cellElems = findChildren (elemName ns "w" "tc") element cells <- mapD (elemToCell ns) cellElems return $ Row cells elemToRow _ _ = throwError WrongElem elemToCell :: NameSpaces -> Element -> D Cell elemToCell ns element | isElem ns "w" "tc" element = do cellContents <- mapD (elemToBodyPart ns) (elChildren element) return $ Cell cellContents elemToCell _ _ = throwError WrongElem elemToParIndentation :: NameSpaces -> Element -> Maybe ParIndentation elemToParIndentation ns element | isElem ns "w" "ind" element = Just $ ParIndentation { leftParIndent = findAttr (QName "left" (lookup "w" ns) (Just "w")) element >>= stringToInteger , rightParIndent = findAttr (QName "right" (lookup "w" ns) (Just "w")) element >>= stringToInteger , hangingParIndent = findAttr (QName "hanging" (lookup "w" ns) (Just "w")) element >>= stringToInteger} elemToParIndentation _ _ = Nothing elemToNumInfo :: NameSpaces -> Element -> Maybe (String, String) elemToNumInfo ns element | isElem ns "w" "p" element = do let pPr = findChild (elemName ns "w" "pPr") element numPr = pPr >>= findChild (elemName ns "w" "numPr") lvl <- numPr >>= findChild (elemName ns "w" "ilvl") >>= findAttr (elemName ns "w" "val") numId <- numPr >>= findChild (elemName ns "w" "numId") >>= findAttr (elemName ns "w" "val") return (numId, lvl) elemToNumInfo _ _ = Nothing testBitMask :: String -> Int -> Bool testBitMask bitMaskS n = case (reads ("0x" ++ bitMaskS) :: [(Int, String)]) of [] -> False ((n', _) : _) -> ((n' .|. n) /= 0) stringToInteger :: String -> Maybe Integer stringToInteger s = listToMaybe $ map fst (reads s :: [(Integer, String)]) elemToBodyPart :: NameSpaces -> Element -> D BodyPart elemToBodyPart ns element | isElem ns "w" "p" element , (c:_) <- findChildren (elemName ns "m" "oMathPara") element = do let style = [] -- placeholder maths <- mapD (elemToMath ns) (elChildren c) return $ OMathPara style maths elemToBodyPart ns element | isElem ns "w" "p" element , Just (numId, lvl) <- elemToNumInfo ns element = do let parstyle = elemToParagraphStyle ns element parparts <- mapD (elemToParPart ns) (elChildren element) num <- asks envNumbering case lookupLevel numId lvl num of Just levelInfo -> return $ ListItem parstyle numId lvl levelInfo parparts Nothing -> throwError WrongElem elemToBodyPart ns element | isElem ns "w" "p" element = do let parstyle = elemToParagraphStyle ns element parparts <- mapD (elemToParPart ns) (elChildren element) return $ Paragraph parstyle parparts elemToBodyPart ns element | isElem ns "w" "tbl" element = do let caption' = findChild (elemName ns "w" "tblPr") element >>= findChild (elemName ns "w" "tblCaption") >>= findAttr (elemName ns "w" "val") caption = (fromMaybe "" caption') grid' = case findChild (elemName ns "w" "tblGrid") element of Just g -> elemToTblGrid ns g Nothing -> return [] tblLook' = case findChild (elemName ns "w" "tblPr") element >>= findChild (elemName ns "w" "tblLook") of Just l -> elemToTblLook ns l Nothing -> return defaultTblLook grid <- grid' tblLook <- tblLook' rows <- mapD (elemToRow ns) (elChildren element) return $ Tbl caption grid tblLook rows elemToBodyPart _ _ = throwError WrongElem elemToMath :: NameSpaces -> Element -> D OMath elemToMath ns element | isElem ns "m" "oMath" element = mapD (elemToMathElem ns) (elChildren element) >>= (\es -> return $ OMath es) elemToMath _ _ = throwError WrongElem elemToBase :: NameSpaces -> Element -> D Base elemToBase ns element | isElem ns "m" "e" element = mapD (elemToMathElem ns) (elChildren element) >>= (\es -> return $ Base es) elemToBase _ _ = throwError WrongElem elemToNAryStyle :: NameSpaces -> Element -> NAryStyle elemToNAryStyle ns element | Just narypr <- findChild (QName "naryPr" (lookup "m" ns) (Just "m")) element = let chr = findChild (QName "chr" (lookup "m" ns) (Just "m")) narypr >>= findAttr (QName "val" (lookup "m" ns) (Just "m")) >>= Just . head limLoc = findChild (QName "limLoc" (lookup "m" ns) (Just "m")) narypr >>= findAttr (QName "val" (lookup "m" ns) (Just "m")) limLoc' = case limLoc of Just "undOver" -> UnderOver Just "subSup" -> SubSup _ -> SubSup in NAryStyle { nAryChar = chr, nAryLimLoc = limLoc'} elemToNAryStyle _ _ = defaultNAryStyle elemToDelimStyle :: NameSpaces -> Element -> DelimStyle elemToDelimStyle ns element | Just dPr <- findChild (QName "dPr" (lookup "m" ns) (Just "m")) element = let begChr = findChild (QName "begChr" (lookup "m" ns) (Just "m")) dPr >>= findAttr (QName "val" (lookup "m" ns) (Just "m")) >>= (\c -> if null c then Nothing else (Just $ head c)) sepChr = findChild (QName "sepChr" (lookup "m" ns) (Just "m")) dPr >>= findAttr (QName "val" (lookup "m" ns) (Just "m")) >>= (\c -> if null c then Nothing else (Just $ head c)) endChr = findChild (QName "endChr" (lookup "m" ns) (Just "m")) dPr >>= findAttr (QName "val" (lookup "m" ns) (Just "m")) >>= (\c -> if null c then Nothing else (Just $ head c)) in DelimStyle { delimBegChar = begChr , delimSepChar = sepChr , delimEndChar = endChr} elemToDelimStyle _ _ = defaultDelimStyle elemToGroupStyle :: NameSpaces -> Element -> GroupStyle elemToGroupStyle ns element | Just gPr <- findChild (QName "groupChrPr" (lookup "m" ns) (Just "m")) element = let chr = findChild (QName "chr" (lookup "m" ns) (Just "m")) gPr >>= findAttr (QName "val" (lookup "m" ns) (Just "m")) >>= Just . head pos = findChild (QName "pos" (lookup "m" ns) (Just "m")) gPr >>= findAttr (QName "val" (lookup "m" ns) (Just "m")) >>= (\s -> Just $ if s == "top" then Top else Bottom) in GroupStyle { groupChr = chr, groupPos = pos } elemToGroupStyle _ _ = defaultGroupStyle elemToMathElem :: NameSpaces -> Element -> D OMathElem elemToMathElem ns element | isElem ns "m" "acc" element = do let accChar = findChild (QName "accPr" (lookup "m" ns) (Just "m")) element >>= findChild (QName "chr" (lookup "m" ns) (Just "m")) >>= findAttr (QName "val" (lookup "m" ns) (Just "m")) >>= Just . head accPr = AccentStyle { accentChar = accChar} base <-(maybeToD $ findChild (elemName ns "m" "e") element) >>= elemToBase ns return $ Accent accPr base elemToMathElem ns element | isElem ns "m" "bar" element = do barPr <- maybeToD $ findChild (QName "barPr" (lookup "m" ns) (Just "m")) element >>= findChild (QName "pos" (lookup "m" ns) (Just "m")) >>= findAttr (QName "val" (lookup "m" ns) (Just "m")) >>= (\s -> Just $ BarStyle { barPos = (if s == "bot" then Bottom else Top) }) base <-maybeToD (findChild (QName "e" (lookup "m" ns) (Just "m")) element) >>= elemToBase ns return $ Bar barPr base elemToMathElem ns element | isElem ns "m" "box" element = maybeToD (findChild (elemName ns "m" "e") element) >>= elemToBase ns >>= (\b -> return $ Box b) elemToMathElem ns element | isElem ns "m" "borderBox" element = maybeToD (findChild (elemName ns "m" "e") element) >>= elemToBase ns >>= (\b -> return $ BorderBox b) elemToMathElem ns element | isElem ns "m" "d" element = let style = elemToDelimStyle ns element in mapD (elemToBase ns) (elChildren element) >>= (\es -> return $ Delimiter style es) elemToMathElem ns element | isElem ns "m" "eqArr" element = mapD (elemToBase ns) (elChildren element) >>= (\es -> return $ EquationArray es) elemToMathElem ns element | isElem ns "m" "f" element = do num <- maybeToD $ findChild (elemName ns "m" "num") element den <- maybeToD $ findChild (elemName ns "m" "den") element numElems <- mapD (elemToMathElem ns) (elChildren num) denElems <- mapD (elemToMathElem ns) (elChildren den) return $ Fraction numElems denElems elemToMathElem ns element | isElem ns "m" "func" element = do fName <- maybeToD $ findChild (elemName ns "m" "fName") element base <- maybeToD (findChild (elemName ns "m" "e") element) >>= elemToBase ns fnElems <- mapD (elemToMathElem ns) (elChildren fName) return $ Function fnElems base elemToMathElem ns element | isElem ns "m" "groupChr" element = let style = elemToGroupStyle ns element in maybeToD (findChild (elemName ns "m" "e") element) >>= elemToBase ns >>= (\b -> return $ Group style b) elemToMathElem ns element | isElem ns "m" "limLow" element = do base <- maybeToD (findChild (elemName ns "m" "e") element) >>= elemToBase ns lim <- maybeToD $ findChild (elemName ns "m" "lim") element limElems <- mapD (elemToMathElem ns) (elChildren lim) return $ LowerLimit base limElems elemToMathElem ns element | isElem ns "m" "limUpp" element = do base <- maybeToD (findChild (elemName ns "m" "e") element) >>= elemToBase ns lim <- maybeToD $ findChild (elemName ns "m" "lim") element limElems <- mapD (elemToMathElem ns) (elChildren lim) return $ UpperLimit base limElems elemToMathElem ns element | isElem ns "m" "m" element = do let rows = findChildren (elemName ns "m" "mr") element bases <- mapD (\mr -> mapD (elemToBase ns) (elChildren mr)) rows return $ Matrix bases elemToMathElem ns element | isElem ns "m" "nary" element = do let style = elemToNAryStyle ns element sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>= (\e -> mapD (elemToMathElem ns) (elChildren e)) sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>= (\e -> mapD (elemToMathElem ns) (elChildren e)) base <- maybeToD (findChild (elemName ns "m" "e") element) >>= elemToBase ns return $ NAry style sub sup base elemToMathElem ns element | isElem ns "m" "rad" element = do deg <- maybeToD (findChild (elemName ns "m" "deg") element) >>= (\e -> mapD (elemToMathElem ns) (elChildren e)) base <- maybeToD (findChild (elemName ns "m" "e") element) >>= elemToBase ns return $ Radical deg base elemToMathElem ns element | isElem ns "m" "phant" element = do base <- maybeToD (findChild (elemName ns "m" "e") element) >>= elemToBase ns return $ Phantom base elemToMathElem ns element | isElem ns "m" "sPre" element = do sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>= (\e -> mapD (elemToMathElem ns) (elChildren e)) sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>= (\e -> mapD (elemToMathElem ns) (elChildren e)) base <- maybeToD (findChild (elemName ns "m" "e") element) >>= elemToBase ns return $ PreSubSuper sub sup base elemToMathElem ns element | isElem ns "m" "sSub" element = do base <- maybeToD (findChild (elemName ns "m" "e") element) >>= elemToBase ns sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>= (\e -> mapD (elemToMathElem ns) (elChildren e)) return $ Sub base sub elemToMathElem ns element | isElem ns "m" "sSubSup" element = do base <- maybeToD (findChild (elemName ns "m" "e") element) >>= elemToBase ns sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>= (\e -> mapD (elemToMathElem ns) (elChildren e)) sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>= (\e -> mapD (elemToMathElem ns) (elChildren e)) return $ SubSuper base sub sup elemToMathElem ns element | isElem ns "m" "sSup" element = do base <- maybeToD (findChild (elemName ns "m" "e") element) >>= elemToBase ns sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>= (\e -> mapD (elemToMathElem ns) (elChildren e)) return $ Sub base sup elemToMathElem ns element | isElem ns "m" "r" element = do let style = [] -- placeholder rstyle = elemToRunStyle ns element relems <- elemToRunElems ns element return $ OMathRun style $ Run rstyle relems elemToMathElem _ _ = throwError WrongElem lookupRelationship :: RelId -> [Relationship] -> Maybe Target lookupRelationship relid rels = lookup relid (map (\(Relationship pair) -> pair) rels) expandDrawingId :: String -> D ParPart expandDrawingId s = do target <- asks (lookupRelationship s . envRelationships) case target of Just t -> do let filepath = combine "word" t bytes <- asks (lookup filepath . envMedia) case bytes of Just bs -> return $ Drawing filepath bs Nothing -> throwError DocxError Nothing -> throwError DocxError elemToParPart :: NameSpaces -> Element -> D ParPart elemToParPart ns element | isElem ns "w" "r" element , Just _ <- findChild (elemName ns "w" "drawing") element = let a_ns = "http://schemas.openxmlformats.org/drawingml/2006/main" drawing = findElement (QName "blip" (Just a_ns) (Just "a")) element >>= findAttr (QName "embed" (lookup "r" ns) (Just "r")) in case drawing of Just s -> expandDrawingId s Nothing -> throwError WrongElem elemToParPart ns element | isElem ns "w" "r" element = elemToRun ns element >>= (\r -> return $ PlainRun r) elemToParPart ns element | isElem ns "w" "ins" element , Just cId <- findAttr (elemName ns "w" "id") element , Just cAuthor <- findAttr (elemName ns "w" "author") element , Just cDate <- findAttr (elemName ns "w" "date") element = do runs <- mapD (elemToRun ns) (elChildren element) return $ Insertion cId cAuthor cDate runs elemToParPart ns element | isElem ns "w" "del" element , Just cId <- findAttr (elemName ns "w" "id") element , Just cAuthor <- findAttr (elemName ns "w" "author") element , Just cDate <- findAttr (elemName ns "w" "date") element = do runs <- mapD (elemToRun ns) (elChildren element) return $ Deletion cId cAuthor cDate runs elemToParPart ns element | isElem ns "w" "bookmarkStart" element , Just bmId <- findAttr (elemName ns "w" "id") element , Just bmName <- findAttr (elemName ns "w" "name") element = return $ BookMark bmId bmName elemToParPart ns element | isElem ns "w" "hyperlink" element , Just anchor <- findAttr (elemName ns "w" "anchor") element = do runs <- mapD (elemToRun ns) (elChildren element) return $ InternalHyperLink anchor runs elemToParPart ns element | isElem ns "w" "hyperlink" element , Just relId <- findAttr (elemName ns "r" "id") element = do runs <- mapD (elemToRun ns) (elChildren element) rels <- asks envRelationships return $ case lookupRelationship relId rels of Just target -> ExternalHyperLink target runs Nothing -> ExternalHyperLink "" runs elemToParPart _ _ = throwError WrongElem lookupFootnote :: String -> Notes -> Maybe Element lookupFootnote s (Notes _ fns _) = fns >>= (M.lookup s) lookupEndnote :: String -> Notes -> Maybe Element lookupEndnote s (Notes _ _ ens) = ens >>= (M.lookup s) elemToRun :: NameSpaces -> Element -> D Run elemToRun ns element | isElem ns "w" "r" element , Just ref <- findChild (elemName ns "w" "footnoteReference") element , Just fnId <- findAttr (elemName ns "w" "id") ref = do notes <- asks envNotes case lookupFootnote fnId notes of Just e -> do bps <- mapD (elemToBodyPart ns) (elChildren e) return $ Footnote bps Nothing -> return $ Footnote [] elemToRun ns element | isElem ns "w" "r" element , Just ref <- findChild (elemName ns "w" "endnoteReference") element , Just enId <- findAttr (elemName ns "w" "id") ref = do notes <- asks envNotes case lookupEndnote enId notes of Just e -> do bps <- mapD (elemToBodyPart ns) (elChildren e) return $ Footnote bps Nothing -> return $ Footnote [] elemToRun ns element | isElem ns "w" "r" element = do runElems <- elemToRunElems ns element return $ Run (elemToRunStyle ns element) runElems elemToRun _ _ = throwError WrongElem elemToParagraphStyle :: NameSpaces -> Element -> ParagraphStyle elemToParagraphStyle ns element | Just pPr <- findChild (elemName ns "w" "pPr") element = ParagraphStyle {pStyle = mapMaybe (findAttr (elemName ns "w" "val")) (findChildren (elemName ns "w" "pStyle") pPr) , indentation = findChild (elemName ns "w" "ind") pPr >>= elemToParIndentation ns } elemToParagraphStyle _ _ = defaultParagraphStyle elemToRunStyle :: NameSpaces -> Element -> RunStyle elemToRunStyle ns element | Just rPr <- findChild (elemName ns "w" "rPr") element = RunStyle { isBold = isJust $ findChild (QName "b" (lookup "w" ns) (Just "w")) rPr , isItalic = isJust $ findChild (QName "i" (lookup "w" ns) (Just "w")) rPr , isSmallCaps = isJust $ findChild (QName "smallCaps" (lookup "w" ns) (Just "w")) rPr , isStrike = isJust $ findChild (QName "strike" (lookup "w" ns) (Just "w")) rPr , isSuperScript = (Just "superscript" == (findChild (QName "vertAlign" (lookup "w" ns) (Just "w")) rPr >>= findAttr (QName "val" (lookup "w" ns) (Just "w")))) , isSubScript = (Just "subscript" == (findChild (QName "vertAlign" (lookup "w" ns) (Just "w")) rPr >>= findAttr (QName "val" (lookup "w" ns) (Just "w")))) , rUnderline = findChild (QName "u" (lookup "w" ns) (Just "w")) rPr >>= findAttr (QName "val" (lookup "w" ns) (Just "w")) , rStyle = findChild (QName "rStyle" (lookup "w" ns) (Just "w")) rPr >>= findAttr (QName "val" (lookup "w" ns) (Just "w")) } elemToRunStyle _ _ = defaultRunStyle elemToRunElem :: NameSpaces -> Element -> D RunElem elemToRunElem ns element | isElem ns "w" "t" element || isElem ns "w" "delText" element = return $ TextRun $ strContent element | isElem ns "w" "br" element = return LnBrk | isElem ns "w" "tab" element = return Tab | otherwise = throwError WrongElem elemToRunElems :: NameSpaces -> Element -> D [RunElem] elemToRunElems ns element | isElem ns "w" "r" element = mapD (elemToRunElem ns) (elChildren element) elemToRunElems _ _ = throwError WrongElem