{-# LANGUAGE PatternGuards, ViewPatterns, FlexibleInstances #-} {- 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(..) , Run(..) , RunElem(..) , Notes , Numbering , Relationship , Media , RunStyle(..) , VertAlign(..) , 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 Control.Applicative ((<$>), (<|>)) import qualified Data.Map as M import Text.Pandoc.Compat.Except import Text.TeXMath.Readers.OMML (readOMML) import Text.Pandoc.Readers.Docx.Fonts (getUnicode, Font(..)) import Text.TeXMath (Exp) import Text.Pandoc.Readers.Docx.Util import Data.Char (readLitChar, ord, chr, isDigit) data ReaderEnv = ReaderEnv { envNotes :: Notes , envNumbering :: Numbering , envRelationships :: [Relationship] , envMedia :: Media , envFont :: Maybe Font , envCharStyles :: CharStyleMap , envParStyles :: ParStyleMap } 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 eitherToD :: Either a b -> D b eitherToD (Right b) = return b eitherToD (Left _) = throwError DocxError concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] concatMapM f xs = liftM concat (mapM f 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 f xs = let handler x = (f x >>= (\y-> return [y])) `catchError` (\_ -> return []) in concatMapM handler xs data Docx = Docx Document deriving Show data Document = Document NameSpaces Body deriving Show data Body = Body [BodyPart] deriving Show type Media = [(FilePath, B.ByteString)] type CharStyle = (String, RunStyle) type ParStyle = (String, ParStyleData) type CharStyleMap = M.Map String RunStyle type ParStyleMap = M.Map String ParStyleData 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 , dropCap :: Bool , pHeading :: Maybe (String, Int) , pNumInfo :: Maybe (String, String) , pBlockQuote :: Maybe Bool } deriving Show defaultParagraphStyle :: ParagraphStyle defaultParagraphStyle = ParagraphStyle { pStyle = [] , indentation = Nothing , dropCap = False , pHeading = Nothing , pNumInfo = Nothing , pBlockQuote = Nothing } data BodyPart = Paragraph ParagraphStyle [ParPart] | ListItem ParagraphStyle String String Level [ParPart] | Tbl String TblGrid TblLook [Row] | OMathPara [Exp] 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 [Exp] deriving Show data Run = Run RunStyle [RunElem] | Footnote [BodyPart] | Endnote [BodyPart] | InlineDrawing FilePath B.ByteString deriving Show data RunElem = TextRun String | LnBrk | Tab deriving Show data VertAlign = BaseLn | SupScrpt | SubScrpt deriving Show data RunStyle = RunStyle { isBold :: Maybe Bool , isItalic :: Maybe Bool , isSmallCaps :: Maybe Bool , isStrike :: Maybe Bool , rVertAlign :: Maybe VertAlign , rUnderline :: Maybe String , rStyle :: Maybe CharStyle} deriving Show data ParStyleData = ParStyleData { headingLev :: Maybe (String, Int) , isBlockQuote :: Maybe Bool , numInfo :: Maybe (String, String) , psStyle :: Maybe ParStyle} deriving Show defaultRunStyle :: RunStyle defaultRunStyle = RunStyle { isBold = Nothing , isItalic = Nothing , isSmallCaps = Nothing , isStrike = Nothing , rVertAlign = Nothing , 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 archiveToDocx :: Archive -> Either DocxError Docx archiveToDocx archive = do let notes = archiveToNotes archive numbering = archiveToNumbering archive rels = archiveToRelationships archive media = archiveToMedia archive (styles, parstyles) = archiveToStyles archive rEnv = ReaderEnv notes numbering rels media Nothing styles parstyles 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 = elemToNameSpaces 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 archiveToStyles :: Archive -> (CharStyleMap, ParStyleMap) archiveToStyles zf = let stylesElem = findEntryByPath "word/styles.xml" zf >>= (parseXMLDoc . UTF8.toStringLazy . fromEntry) in case stylesElem of Nothing -> (M.empty, M.empty) Just styElem -> let namespaces = elemToNameSpaces styElem in ( M.fromList $ buildBasedOnList namespaces styElem (Nothing :: Maybe CharStyle), M.fromList $ buildBasedOnList namespaces styElem (Nothing :: Maybe ParStyle) ) isBasedOnStyle :: (ElemToStyle a) => NameSpaces -> Element -> Maybe a -> Bool isBasedOnStyle ns element parentStyle | isElem ns "w" "style" element , Just styleType <- findAttr (elemName ns "w" "type") element , styleType == cStyleType parentStyle , Just basedOnVal <- findChild (elemName ns "w" "basedOn") element >>= findAttr (elemName ns "w" "val") , Just ps <- parentStyle = (basedOnVal == getStyleId ps) | isElem ns "w" "style" element , Just styleType <- findAttr (elemName ns "w" "type") element , styleType == cStyleType parentStyle , Nothing <- findChild (elemName ns "w" "basedOn") element , Nothing <- parentStyle = True | otherwise = False class ElemToStyle a where cStyleType :: Maybe a -> String elemToStyle :: NameSpaces -> Element -> Maybe a -> Maybe a getStyleId :: a -> String instance ElemToStyle CharStyle where cStyleType _ = "character" elemToStyle ns element parentStyle | isElem ns "w" "style" element , Just "character" <- findAttr (elemName ns "w" "type") element , Just styleId <- findAttr (elemName ns "w" "styleId") element = Just (styleId, elemToRunStyle ns element parentStyle) | otherwise = Nothing getStyleId s = fst s instance ElemToStyle ParStyle where cStyleType _ = "paragraph" elemToStyle ns element parentStyle | isElem ns "w" "style" element , Just "paragraph" <- findAttr (elemName ns "w" "type") element , Just styleId <- findAttr (elemName ns "w" "styleId") element = Just (styleId, elemToParStyleData ns element parentStyle) | otherwise = Nothing getStyleId s = fst s getStyleChildren :: (ElemToStyle a) => NameSpaces -> Element -> Maybe a -> [a] getStyleChildren ns element parentStyle | isElem ns "w" "styles" element = mapMaybe (\e -> elemToStyle ns e parentStyle) $ filterChildren (\e' -> isBasedOnStyle ns e' parentStyle) element | otherwise = [] buildBasedOnList :: (ElemToStyle a) => NameSpaces -> Element -> Maybe a -> [a] buildBasedOnList ns element rootStyle = case (getStyleChildren ns element rootStyle) of [] -> [] stys -> stys ++ (concatMap (\s -> buildBasedOnList ns element (Just s)) stys) 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 -> elemToNameSpaces e Nothing -> [] en_namespaces = case enElem of Just e -> elemToNameSpaces 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 = elemToNameSpaces 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 --------------------------------------------- --------------------------------------------- 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 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 expsLst <- eitherToD $ readOMML $ showElement c return $ OMathPara expsLst elemToBodyPart ns element | isElem ns "w" "p" element , Just (numId, lvl) <- getNumInfo ns element = do sty <- asks envParStyles let parstyle = elemToParagraphStyle ns element sty 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 sty <- asks envParStyles let parstyle = elemToParagraphStyle ns element sty parparts <- mapD (elemToParPart ns) (elChildren element) case pNumInfo parstyle of Just (numId, lvl) -> do num <- asks envNumbering case lookupLevel numId lvl num of Just levelInfo -> return $ ListItem parstyle numId lvl levelInfo parparts Nothing -> throwError WrongElem Nothing -> 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 lookupRelationship :: RelId -> [Relationship] -> Maybe Target lookupRelationship relid rels = lookup relid (map (\(Relationship pair) -> pair) rels) expandDrawingId :: String -> D (FilePath, B.ByteString) expandDrawingId s = do target <- asks (lookupRelationship s . envRelationships) case target of Just filepath -> do bytes <- asks (lookup ("word/" ++ filepath) . envMedia) case bytes of Just bs -> return (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 >>= (\(fp, bs) -> return $ Drawing fp bs) Nothing -> throwError WrongElem -- The below is an attempt to deal with images in deprecated vml format. elemToParPart ns element | isElem ns "w" "r" element , Just _ <- findChild (elemName ns "w" "pict") element = let drawing = findElement (elemName ns "v" "imagedata") element >>= findAttr (elemName ns "r" "id") in case drawing of Just s -> expandDrawingId s >>= (\(fp, bs) -> return $ Drawing fp bs) 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 relId <- findAttr (elemName ns "r" "id") element = do runs <- mapD (elemToRun ns) (elChildren element) rels <- asks envRelationships case lookupRelationship relId rels of Just target -> do case findAttr (elemName ns "w" "anchor") element of Just anchor -> return $ ExternalHyperLink (target ++ '#':anchor) runs Nothing -> return $ ExternalHyperLink target runs Nothing -> return $ ExternalHyperLink "" runs 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 "m" "oMath" element = (eitherToD $ readOMML $ showElement element) >>= (return . PlainOMath) 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 drawingElem <- 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")) drawingElem >>= findAttr (QName "embed" (lookup "r" ns) (Just "r")) in case drawing of Just s -> expandDrawingId s >>= (\(fp, bs) -> return $ InlineDrawing fp bs) Nothing -> throwError WrongElem 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 $ Endnote bps Nothing -> return $ Endnote [] elemToRun ns element | isElem ns "w" "r" element = do runElems <- elemToRunElems ns element runStyle <- elemToRunStyleD ns element return $ Run runStyle runElems elemToRun _ _ = throwError WrongElem getParentStyleValue :: (ParStyleData -> Maybe a) -> ParStyleData -> Maybe a getParentStyleValue field style | Just value <- field style = Just value | Just parentStyle <- psStyle style = getParentStyleValue field (snd parentStyle) getParentStyleValue _ _ = Nothing getParStyleField :: (ParStyleData -> Maybe a) -> ParStyleMap -> [String] -> Maybe a getParStyleField field stylemap styles | x <- mapMaybe (\x -> M.lookup x stylemap) styles , (y:_) <- mapMaybe (getParentStyleValue field) x = Just y getParStyleField _ _ _ = Nothing elemToParagraphStyle :: NameSpaces -> Element -> ParStyleMap -> ParagraphStyle elemToParagraphStyle ns element sty | Just pPr <- findChild (elemName ns "w" "pPr") element = let style = mapMaybe (findAttr (elemName ns "w" "val")) (findChildren (elemName ns "w" "pStyle") pPr) in ParagraphStyle {pStyle = style , indentation = findChild (elemName ns "w" "ind") pPr >>= elemToParIndentation ns , dropCap = case findChild (elemName ns "w" "framePr") pPr >>= findAttr (elemName ns "w" "dropCap") of Just "none" -> False Just _ -> True Nothing -> False , pHeading = getParStyleField headingLev sty style , pNumInfo = getParStyleField numInfo sty style , pBlockQuote = getParStyleField isBlockQuote sty style } elemToParagraphStyle _ _ _ = defaultParagraphStyle checkOnOff :: NameSpaces -> Element -> QName -> Maybe Bool checkOnOff ns rPr tag | Just t <- findChild tag rPr , Just val <- findAttr (elemName ns "w" "val") t = Just $ case val of "true" -> True "false" -> False "on" -> True "off" -> False "1" -> True "0" -> False _ -> False | Just _ <- findChild tag rPr = Just True checkOnOff _ _ _ = Nothing elemToRunStyleD :: NameSpaces -> Element -> D RunStyle elemToRunStyleD ns element | Just rPr <- findChild (elemName ns "w" "rPr") element = do charStyles <- asks envCharStyles let parentSty = case findChild (elemName ns "w" "rStyle") rPr >>= findAttr (elemName ns "w" "val") of Just styName | Just style <- M.lookup styName charStyles -> Just (styName, style) _ -> Nothing return $ elemToRunStyle ns element parentSty elemToRunStyleD _ _ = return defaultRunStyle elemToRunStyle :: NameSpaces -> Element -> Maybe CharStyle -> RunStyle elemToRunStyle ns element parentStyle | Just rPr <- findChild (elemName ns "w" "rPr") element = RunStyle { isBold = checkOnOff ns rPr (elemName ns "w" "b") , isItalic = checkOnOff ns rPr (elemName ns "w" "i") , isSmallCaps = checkOnOff ns rPr (elemName ns "w" "smallCaps") , isStrike = checkOnOff ns rPr (elemName ns "w" "strike") , rVertAlign = findChild (elemName ns "w" "vertAlign") rPr >>= findAttr (elemName ns "w" "val") >>= \v -> Just $ case v of "superscript" -> SupScrpt "subscript" -> SubScrpt _ -> BaseLn , rUnderline = findChild (elemName ns "w" "u") rPr >>= findAttr (elemName ns "w" "val") , rStyle = parentStyle } elemToRunStyle _ _ _ = defaultRunStyle isNumericNotNull :: String -> Bool isNumericNotNull str = (str /= []) && (all isDigit str) getHeaderLevel :: NameSpaces -> Element -> Maybe (String,Int) getHeaderLevel ns element | Just styleId <- findAttr (elemName ns "w" "styleId") element , Just index <- stripPrefix "Heading" styleId , isNumericNotNull index = Just (styleId, read index) | Just styleId <- findAttr (elemName ns "w" "styleId") element , Just index <- findChild (elemName ns "w" "name") element >>= findAttr (elemName ns "w" "val") >>= stripPrefix "heading " , isNumericNotNull index = Just (styleId, read index) getHeaderLevel _ _ = Nothing blockQuoteStyleIds :: [String] blockQuoteStyleIds = ["Quote", "BlockQuote", "BlockQuotation"] blockQuoteStyleNames :: [String] blockQuoteStyleNames = ["Quote", "Block Text"] getBlockQuote :: NameSpaces -> Element -> Maybe Bool getBlockQuote ns element | Just styleId <- findAttr (elemName ns "w" "styleId") element , styleId `elem` blockQuoteStyleIds = Just True | Just styleName <- findChild (elemName ns "w" "name") element >>= findAttr (elemName ns "w" "val") , styleName `elem` blockQuoteStyleNames = Just True getBlockQuote _ _ = Nothing getNumInfo :: NameSpaces -> Element -> Maybe (String, String) getNumInfo ns element = do let numPr = findChild (elemName ns "w" "pPr") element >>= findChild (elemName ns "w" "numPr") lvl = fromMaybe "0" (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) elemToParStyleData :: NameSpaces -> Element -> Maybe ParStyle -> ParStyleData elemToParStyleData ns element parentStyle = ParStyleData { headingLev = getHeaderLevel ns element , isBlockQuote = getBlockQuote ns element , numInfo = getNumInfo ns element , psStyle = parentStyle } elemToRunElem :: NameSpaces -> Element -> D RunElem elemToRunElem ns element | isElem ns "w" "t" element || isElem ns "w" "delText" element || isElem ns "m" "t" element = do let str = strContent element font <- asks envFont case font of Nothing -> return $ TextRun str Just f -> return . TextRun $ map (\x -> fromMaybe x . getUnicode f . lowerFromPrivate $ x) str | isElem ns "w" "br" element = return LnBrk | isElem ns "w" "tab" element = return Tab | isElem ns "w" "sym" element = return (getSymChar ns element) | otherwise = throwError WrongElem where lowerFromPrivate (ord -> c) | c >= ord '\xF000' = chr $ c - ord '\xF000' | otherwise = chr c -- The char attribute is a hex string getSymChar :: NameSpaces -> Element -> RunElem getSymChar ns element | Just s <- lowerFromPrivate <$> getCodepoint , Just font <- getFont = let [(char, _)] = readLitChar ("\\x" ++ s) in TextRun . maybe "" (:[]) $ getUnicode font char where getCodepoint = findAttr (elemName ns "w" "char") element getFont = stringToFont =<< findAttr (elemName ns "w" "font") element lowerFromPrivate ('F':xs) = '0':xs lowerFromPrivate xs = xs getSymChar _ _ = TextRun "" stringToFont :: String -> Maybe Font stringToFont "Symbol" = Just Symbol stringToFont _ = Nothing elemToRunElems :: NameSpaces -> Element -> D [RunElem] elemToRunElems ns element | isElem ns "w" "r" element || isElem ns "m" "r" element = do let qualName = elemName ns "w" let font = do fontElem <- findElement (qualName "rFonts") element stringToFont =<< (foldr (<|>) Nothing $ map (flip findAttr fontElem . qualName) ["ascii", "hAnsi"]) local (setFont font) (mapD (elemToRunElem ns) (elChildren element)) elemToRunElems _ _ = throwError WrongElem setFont :: Maybe Font -> ReaderEnv -> ReaderEnv setFont f s = s{envFont = f}