aboutsummaryrefslogtreecommitdiff
path: root/src/Text/Pandoc
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/Pandoc')
-rw-r--r--src/Text/Pandoc/Compat/Except.hs27
-rw-r--r--src/Text/Pandoc/Readers/Docx.hs108
-rw-r--r--src/Text/Pandoc/Readers/Docx/Parse.hs1355
3 files changed, 739 insertions, 751 deletions
diff --git a/src/Text/Pandoc/Compat/Except.hs b/src/Text/Pandoc/Compat/Except.hs
new file mode 100644
index 000000000..7f5648e7a
--- /dev/null
+++ b/src/Text/Pandoc/Compat/Except.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE CPP #-}
+module Text.Pandoc.Compat.Except ( ExceptT
+ , Error(..)
+ , runExceptT
+ , throwError
+ , catchError )
+ where
+
+#if MIN_VERSION_mtl(2,2,1)
+import Control.Monad.Except
+
+class Error a where
+ noMsg :: a
+ strMsg :: String -> a
+
+ noMsg = strMsg ""
+ strMsg _ = noMsg
+
+#else
+import Control.Monad.Error
+type ExceptT = ErrorT
+
+runExceptT :: ExceptT e m a -> m (Either e a)
+runExceptT = runErrorT
+#endif
+
+
diff --git a/src/Text/Pandoc/Readers/Docx.hs b/src/Text/Pandoc/Readers/Docx.hs
index 9f73f2e7f..fe4c6b7e6 100644
--- a/src/Text/Pandoc/Readers/Docx.hs
+++ b/src/Text/Pandoc/Readers/Docx.hs
@@ -91,7 +91,6 @@ import Data.List (delete, isPrefixOf, (\\), intercalate)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as B
import Data.ByteString.Base64 (encode)
-import System.FilePath (combine)
import qualified Data.Map as M
import Control.Monad.Reader
import Control.Monad.State
@@ -102,8 +101,8 @@ readDocx :: ReaderOptions
-> Pandoc
readDocx opts bytes =
case archiveToDocx (toArchive bytes) of
- Just docx -> Pandoc nullMeta (docxToBlocks opts docx)
- Nothing -> error $ "couldn't parse docx file"
+ Right docx -> Pandoc nullMeta (docxToBlocks opts docx)
+ Left _ -> error $ "couldn't parse docx file"
data DState = DState { docxAnchorMap :: M.Map String String
, docxInTexSubscript :: Bool }
@@ -159,7 +158,7 @@ runStyleToContainers rPr =
, if isStrike rPr then (Just Strikeout) else Nothing
, if isSuperScript rPr then (Just Superscript) else Nothing
, if isSubScript rPr then (Just Subscript) else Nothing
- , underline rPr >>= (\f -> Just $ Span ("", [], [("underline", f)]))
+ , rUnderline rPr >>= (\f -> Just $ Span ("", [], [("underline", f)]))
]
in
classContainers ++ formatters
@@ -259,20 +258,17 @@ runToInlines (Run rs runElems)
| otherwise =
return $
rebuild (runStyleToContainers rs) (concatMap runElemToInlines runElems)
-runToInlines (Footnote fnId) = do
- (Docx _ notes _ _ _ ) <- asks docxDocument
- case (getFootNote fnId notes) of
- Just bodyParts -> do
- blks <- concatMapM bodyPartToBlocks bodyParts
- return $ [Note blks]
- Nothing -> return [Note []]
-runToInlines (Endnote fnId) = do
- (Docx _ notes _ _ _ ) <- asks docxDocument
- case (getEndNote fnId notes) of
- Just bodyParts -> do
- blks <- concatMapM bodyPartToBlocks bodyParts
- return $ [Note blks]
- Nothing -> return [Note []]
+runToInlines (Footnote bps) =
+ concatMapM bodyPartToBlocks bps >>= (\blks -> return [Note blks])
+runToInlines (Endnote bps) =
+ concatMapM bodyPartToBlocks bps >>= (\blks -> return [Note blks])
+
+makeDataUrl :: String -> B.ByteString -> Maybe String
+makeDataUrl fp bs =
+ case getMimeType fp of
+ Just mime -> Just $ "data:" ++ mime ++ ";base64," ++
+ toString (encode $ BS.concat $ B.toChunks bs)
+ Nothing -> Nothing
parPartToInlines :: ParPart -> DocxContext [Inline]
parPartToInlines (PlainRun r) = runToInlines r
@@ -313,22 +309,18 @@ parPartToInlines (BookMark _ anchor) =
False -> anchor
updateDState $ \s -> s { docxAnchorMap = M.insert anchor newAnchor anchorMap}
return [Span (anchor, ["anchor"], []) []]
-parPartToInlines (Drawing relid) = do
- (Docx _ _ _ rels _) <- asks docxDocument
- return $ case lookupRelationship relid rels of
- Just target -> [Image [] (combine "word" target, "")]
- Nothing -> [Image [] ("", "")]
+parPartToInlines (Drawing fp bs) = do
+ return $ case True of -- TODO: add self-contained images
+ True -> [Image [] (fp, "")]
+ False -> case makeDataUrl fp bs of
+ Just d -> [Image [] (d, "")]
+ Nothing -> [Image [] ("", "")]
parPartToInlines (InternalHyperLink anchor runs) = do
ils <- concatMapM runToInlines runs
return [Link ils ('#' : anchor, "")]
-parPartToInlines (ExternalHyperLink relid runs) = do
- (Docx _ _ _ rels _) <- asks docxDocument
- rs <- concatMapM runToInlines runs
- return $ case lookupRelationship relid rels of
- Just target ->
- [Link rs (target, "")]
- Nothing ->
- [Link rs ("", "")]
+parPartToInlines (ExternalHyperLink target runs) = do
+ ils <- concatMapM runToInlines runs
+ return [Link ils (target, "")]
parPartToInlines (PlainOMath omath) = do
s <- oMathToTexString omath
return [Math InlineMath s]
@@ -450,6 +442,9 @@ oMathElemToTexString (NAry _ sub sup base) = do
baseString <- baseToTexString base
return $ printf "\\int_{%s}^{%s}{%s}"
subString supString baseString
+oMathElemToTexString (Phantom base) = do
+ baseString <- baseToTexString base
+ return $ printf "\\phantom{%s}" baseString
oMathElemToTexString (Radical degree base) = do
degString <- concatMapM oMathElemToTexString degree
baseString <- baseToTexString base
@@ -475,7 +470,6 @@ oMathElemToTexString (Super base sup) = do
supString <- concatMapM oMathElemToTexString sup
return $ printf "%s^{%s}" baseString supString
oMathElemToTexString (OMathRun _ run) = return $ stringToTex $ runToString run
-oMathElemToTexString _ = return "[NOT IMPLEMENTED]"
baseToTexString :: Base -> DocxContext String
baseToTexString (Base mathElems) =
@@ -518,9 +512,7 @@ makeHeaderAnchor blk = return blk
parPartsToInlines :: [ParPart] -> DocxContext [Inline]
parPartsToInlines parparts = do
- ils <- concatMapM parPartToInlines parparts >>=
- -- TODO: Option for self-containted images
- (if False then (walkM makeImagesSelfContained) else return)
+ ils <- concatMapM parPartToInlines parparts
return $ reduceList $ ils
cellToBlocks :: Cell -> DocxContext [Block]
@@ -563,23 +555,21 @@ bodyPartToBlocks (Paragraph pPr parparts) = do
rebuild
(parStyleToContainers pPr)
[Para ils]
-bodyPartToBlocks (ListItem pPr numId lvl parparts) = do
- (Docx _ _ numbering _ _) <- asks docxDocument
+bodyPartToBlocks (ListItem pPr numId lvl levelInfo parparts) = do
let
- kvs = case lookupLevel numId lvl numbering of
- Just (_, fmt, txt, Just start) -> [ ("level", lvl)
- , ("num-id", numId)
- , ("format", fmt)
- , ("text", txt)
- , ("start", (show start))
- ]
-
- Just (_, fmt, txt, Nothing) -> [ ("level", lvl)
- , ("num-id", numId)
- , ("format", fmt)
- , ("text", txt)
- ]
- Nothing -> []
+ kvs = case levelInfo of
+ (_, fmt, txt, Just start) -> [ ("level", lvl)
+ , ("num-id", numId)
+ , ("format", fmt)
+ , ("text", txt)
+ , ("start", (show start))
+ ]
+
+ (_, fmt, txt, Nothing) -> [ ("level", lvl)
+ , ("num-id", numId)
+ , ("format", fmt)
+ , ("text", txt)
+ ]
blks <- bodyPartToBlocks (Paragraph pPr parparts)
return $ [Div ("", ["list-item"], kvs) blks]
bodyPartToBlocks (Tbl _ _ _ []) =
@@ -622,20 +612,6 @@ rewriteLink l@(Link ils ('#':target, title)) = do
Nothing -> l
rewriteLink il = return il
-makeImagesSelfContained :: Inline -> DocxContext Inline
-makeImagesSelfContained i@(Image alt (uri, title)) = do
- (Docx _ _ _ _ media) <- asks docxDocument
- return $ case lookup uri media of
- Just bs ->
- case getMimeType uri of
- Just mime ->
- let data_uri = "data:" ++ mime ++ ";base64," ++
- toString (encode $ BS.concat $ B.toChunks bs)
- in
- Image alt (data_uri, title)
- Nothing -> i
- Nothing -> i
-makeImagesSelfContained inline = return inline
bodyToBlocks :: Body -> DocxContext [Block]
bodyToBlocks (Body bps) = do
@@ -646,7 +622,7 @@ bodyToBlocks (Body bps) = do
blocksToBullets $ blks
docxToBlocks :: ReaderOptions -> Docx -> [Block]
-docxToBlocks opts d@(Docx (Document _ body) _ _ _ _) =
+docxToBlocks opts d@(Docx (Document _ body)) =
let dState = DState { docxAnchorMap = M.empty
, docxInTexSubscript = False}
dEnv = DEnv { docxOptions = opts
diff --git a/src/Text/Pandoc/Readers/Docx/Parse.hs b/src/Text/Pandoc/Readers/Docx/Parse.hs
index 44585b016..4b5a11fa8 100644
--- a/src/Text/Pandoc/Readers/Docx/Parse.hs
+++ b/src/Text/Pandoc/Readers/Docx/Parse.hs
@@ -10,59 +10,55 @@ the Free Software Foundation; either version 2 of the License, or
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
+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
+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
+ Module : Text.Pandoc.Readers.Docx.Parse
+ Copyright : Copyright (C) 2014 Jesse Rosenthal
+ License : GNU GPL, version 2 or above
- Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
- Stability : alpha
- Portability : portable
+ 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(..)
+ , ParPart(..)
+ , OMath(..)
+ , OMathElem(..)
+ , Base(..)
+ , TopBottom(..)
+ , AccentStyle(..)
+ , BarStyle(..)
+ , NAryStyle(..)
+ , DelimStyle(..)
+ , GroupStyle(..)
+ , Run(..)
+ , RunElem(..)
+ , Notes
+ , Numbering
+ , Relationship
+ , Media
+ , RunStyle(..)
+ , ParIndentation(..)
+ , ParagraphStyle(..)
+ , Row(..)
+ , Cell(..)
+ , archiveToDocx
+ ) where
-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(..)
- , getFootNote
- , getEndNote
- , lookupLevel
- , lookupRelationship
- , archiveToDocx
- ) where
import Codec.Archive.Zip
import Text.XML.Light
import Data.Maybe
@@ -71,56 +67,53 @@ 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
-attrToNSPair :: Attr -> Maybe (String, String)
-attrToNSPair (Attr (QName s _ (Just "xmlns")) val) = Just (s, val)
-attrToNSPair _ = Nothing
+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 Notes Numbering [Relationship] Media
+data Docx = Docx Document
deriving Show
-archiveToDocx :: Archive -> Maybe Docx
-archiveToDocx archive = do
- let notes = archiveToNotes archive
- rels = archiveToRelationships archive
- media = archiveToMedia archive
- doc <- archiveToDocument archive
- numbering <- archiveToNumbering archive
- return $ Docx doc notes numbering rels media
-
data Document = Document NameSpaces Body
deriving Show
-archiveToDocument :: Archive -> Maybe Document
-archiveToDocument zf = do
- entry <- findEntryByPath "word/document.xml" zf
- docElem <- (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry
- let namespaces = mapMaybe attrToNSPair (elAttribs docElem)
- bodyElem <- findChild (QName "body" (lookup "w" namespaces) Nothing) docElem
- body <- elemToBody namespaces bodyElem
- return $ Document namespaces body
+data Body = Body [BodyPart]
+ deriving Show
type Media = [(FilePath, B.ByteString)]
-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))
-
data Numbering = Numbering NameSpaces [Numb] [AbstractNumb]
deriving Show
@@ -133,240 +126,12 @@ data AbstractNumb = AbstractNumb String [Level]
-- (ilvl, format, string, start)
type Level = (String, String, String, Maybe Integer)
-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 =
- 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
-
-data Notes = Notes NameSpaces (Maybe [(String, [BodyPart])]) (Maybe [(String, [BodyPart])])
- deriving Show
-
-noteElemToNote :: NameSpaces -> Element -> Maybe (String, [BodyPart])
-noteElemToNote ns element
- | qName (elName element) `elem` ["endnote", "footnote"] &&
- qURI (elName element) == (lookup "w" ns) =
- do
- noteId <- findAttr (QName "id" (lookup "w" ns) (Just "w")) element
- let bps = mapMaybe (elemToBodyPart ns)
- $ elChildren element
- return $ (noteId, bps)
-noteElemToNote _ _ = Nothing
-
-getFootNote :: String -> Notes -> Maybe [BodyPart]
-getFootNote s (Notes _ fns _) = fns >>= (lookup s)
-
-getEndNote :: String -> Notes -> Maybe [BodyPart]
-getEndNote s (Notes _ _ ens) = ens >>= (lookup s)
-
-elemToNotes :: NameSpaces -> String -> Element -> Maybe [(String, [BodyPart])]
-elemToNotes ns notetype element
- | qName (elName element) == (notetype ++ "s") &&
- qURI (elName element) == (lookup "w" ns) =
- Just $ mapMaybe (noteElemToNote ns)
- $ findChildren (QName notetype (lookup "w" ns) (Just "w")) element
-elemToNotes _ _ _ = Nothing
-
-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
-
-
data Relationship = Relationship (RelId, Target)
deriving Show
-
-lookupRelationship :: RelId -> [Relationship] -> Maybe Target
-lookupRelationship relid rels =
- lookup relid (map (\(Relationship pair) -> pair) rels)
-
-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
-
-data Body = Body [BodyPart]
- deriving Show
-
-elemToBody :: NameSpaces -> Element -> Maybe Body
-elemToBody ns element | qName (elName element) == "body" && qURI (elName element) == (lookup "w" ns) =
- Just $ Body
- $ mapMaybe (elemToBodyPart ns) $ elChildren element
-elemToBody _ _ = Nothing
-
-elemToNumInfo :: NameSpaces -> Element -> Maybe (String, String)
-elemToNumInfo ns element
- | qName (elName element) == "p" &&
- qURI (elName element) == (lookup "w" ns) =
- do
- pPr <- findChild (QName "pPr" (lookup "w" ns) (Just "w")) element
- numPr <- findChild (QName "numPr" (lookup "w" ns) (Just "w")) pPr
- lvl <- findChild (QName "ilvl" (lookup "w" ns) (Just "w")) numPr >>=
- findAttr (QName "val" (lookup "w" ns) (Just "w"))
- numId <- findChild (QName "numId" (lookup "w" ns) (Just "w")) numPr >>=
- findAttr (QName "val" (lookup "w" ns) (Just "w"))
- return (numId, lvl)
-elemToNumInfo _ _ = Nothing
-
-elemToBodyPart :: NameSpaces -> Element -> Maybe BodyPart
-elemToBodyPart ns element
- | qName (elName element) == "p" &&
- qURI (elName element) == (lookup "w" ns)
- , (c:_) <- findChildren (QName "oMathPara" (lookup "m" ns) (Just "m")) element =
- let style = [] -- placeholder
- maths = mapMaybe (elemToMath ns)
- $ findChildren
- (QName "oMath" (lookup "m" ns) (Just "m")) c
- in
- Just $ OMathPara style maths
- | qName (elName element) == "p" &&
- qURI (elName element) == (lookup "w" ns)
- , Just (numId, lvl) <- elemToNumInfo ns element =
- let parstyle = elemToParagraphStyle ns element
- parparts = mapMaybe (elemToParPart ns)
- $ elChildren element
- in
- Just $ ListItem parstyle numId lvl parparts
- | qName (elName element) == "p" &&
- qURI (elName element) == (lookup "w" ns) =
- let parstyle = elemToParagraphStyle ns element
- parparts = mapMaybe (elemToParPart ns)
- $ elChildren element
- in
- Just $ Paragraph parstyle parparts
- | qName (elName element) == "tbl" &&
- qURI (elName element) == (lookup "w" ns) =
- let
- caption = findChild (QName "tblPr" (lookup "w" ns) (Just "w")) element
- >>= findChild (QName "tblCaption" (lookup "w" ns) (Just "w"))
- >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
- grid = case
- findChild (QName "tblGrid" (lookup "w" ns) (Just "w")) element
- of
- Just g -> elemToTblGrid ns g
- Nothing -> []
- tblLook = findChild (QName "tblPr" (lookup "w" ns) (Just "w")) element
- >>= findChild (QName "tblLook" (lookup "w" ns) (Just "w"))
- >>= elemToTblLook ns
- in
- Just $ Tbl
- (fromMaybe "" caption)
- grid
- (fromMaybe defaultTblLook tblLook)
- (mapMaybe (elemToRow ns) (elChildren element))
- | otherwise = Nothing
-
-elemToTblLook :: NameSpaces -> Element -> Maybe TblLook
-elemToTblLook ns element
- | qName (elName element) == "tblLook" &&
- qURI (elName element) == (lookup "w" ns) =
- let firstRow = findAttr (QName "firstRow" (lookup "w" ns) (Just "w")) element
- val = findAttr (QName "val" (lookup "w" ns) (Just "w")) element
- firstRowFmt =
- case firstRow of
- Just "1" -> True
- Just _ -> False
- Nothing -> case val of
- Just bitMask -> testBitMask bitMask 0x020
- Nothing -> False
- in
- Just $ TblLook{firstRowFormatting = firstRowFmt}
-elemToTblLook _ _ = Nothing
-
-testBitMask :: String -> Int -> Bool
-testBitMask bitMaskS n =
- case (reads ("0x" ++ bitMaskS) :: [(Int, String)]) of
- [] -> False
- ((n', _) : _) -> ((n' .|. n) /= 0)
+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
@@ -383,40 +148,9 @@ defaultParagraphStyle = ParagraphStyle { pStyle = []
, indentation = Nothing
}
-elemToParIndentation :: NameSpaces -> Element -> Maybe ParIndentation
-elemToParIndentation ns element
- | qName (elName element) == "ind" &&
- qURI (elName element) == (lookup "w" ns) =
- 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
-
-elemToParagraphStyle :: NameSpaces -> Element -> ParagraphStyle
-elemToParagraphStyle ns element =
- case findChild (QName "pPr" (lookup "w" ns) (Just "w")) element of
- Just pPr ->
- ParagraphStyle
- {pStyle =
- mapMaybe
- (findAttr (QName "val" (lookup "w" ns) (Just "w")))
- (findChildren (QName "pStyle" (lookup "w" ns) (Just "w")) pPr)
- , indentation =
- findChild (QName "ind" (lookup "w" ns) (Just "w")) pPr >>=
- elemToParIndentation ns
- }
- Nothing -> defaultParagraphStyle
-
data BodyPart = Paragraph ParagraphStyle [ParPart]
- | ListItem ParagraphStyle String String [ParPart]
+ | ListItem ParagraphStyle String String Level [ParPart]
| Tbl String TblGrid TblLook [Row]
| OMathPara OMathParaStyle [OMath]
deriving Show
@@ -429,62 +163,22 @@ data TblLook = TblLook {firstRowFormatting::Bool}
defaultTblLook :: TblLook
defaultTblLook = TblLook{firstRowFormatting = False}
-stringToInteger :: String -> Maybe Integer
-stringToInteger s = listToMaybe $ map fst (reads s :: [(Integer, String)])
-
-elemToTblGrid :: NameSpaces -> Element -> TblGrid
-elemToTblGrid ns element
- | qName (elName element) == "tblGrid" &&
- qURI (elName element) == (lookup "w" ns) =
- let
- cols = findChildren (QName "gridCol" (lookup "w" ns) (Just "w")) element
- in
- mapMaybe (\e ->
- findAttr (QName "val" (lookup "w" ns) (Just ("w"))) e
- >>= stringToInteger
- )
- cols
-elemToTblGrid _ _ = []
-
data Row = Row [Cell]
deriving Show
-
-elemToRow :: NameSpaces -> Element -> Maybe Row
-elemToRow ns element
- | qName (elName element) == "tr" &&
- qURI (elName element) == (lookup "w" ns) =
- let
- cells = findChildren (QName "tc" (lookup "w" ns) (Just "w")) element
- in
- Just $ Row (mapMaybe (elemToCell ns) cells)
-elemToRow _ _ = Nothing
-
data Cell = Cell [BodyPart]
deriving Show
-elemToCell :: NameSpaces -> Element -> Maybe Cell
-elemToCell ns element
- | qName (elName element) == "tc" &&
- qURI (elName element) == (lookup "w" ns) =
- Just $ Cell (mapMaybe (elemToBodyPart ns) (elChildren element))
-elemToCell _ _ = Nothing
-
data ParPart = PlainRun Run
| Insertion ChangeId Author ChangeDate [Run]
| Deletion ChangeId Author ChangeDate [Run]
| BookMark BookMarkId Anchor
| InternalHyperLink Anchor [Run]
- | ExternalHyperLink RelId [Run]
- | Drawing String
+ | ExternalHyperLink URL [Run]
+ | Drawing FilePath B.ByteString
| PlainOMath OMath
deriving Show
-data Run = Run RunStyle [RunElem]
- | Footnote String
- | Endnote String
- deriving Show
-
data OMath = OMath [OMathElem]
deriving Show
@@ -554,6 +248,12 @@ 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
@@ -563,7 +263,7 @@ data RunStyle = RunStyle { isBold :: Bool
, isStrike :: Bool
, isSuperScript :: Bool
, isSubScript :: Bool
- , underline :: Maybe String
+ , rUnderline :: Maybe String
, rStyle :: Maybe String }
deriving Show
@@ -574,104 +274,327 @@ defaultRunStyle = RunStyle { isBold = False
, isStrike = False
, isSuperScript = False
, isSubScript = False
- , underline = Nothing
+ , rUnderline = Nothing
, rStyle = Nothing
}
-elemToRunStyle :: NameSpaces -> Element -> RunStyle
-elemToRunStyle ns element =
- case findChild (QName "rPr" (lookup "w" ns) (Just "w")) element of
- Just rPr ->
- 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"))))
- , underline =
- 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"))
- }
- Nothing -> defaultRunStyle
-elemToRun :: NameSpaces -> Element -> Maybe Run
-elemToRun ns element
- | qName (elName element) == "r" &&
- qURI (elName element) == (lookup "w" ns) =
- case
- findChild (QName "footnoteReference" (lookup "w" ns) (Just "w")) element >>=
- findAttr (QName "id" (lookup "w" ns) (Just "w"))
- of
- Just s -> Just $ Footnote s
- Nothing ->
- case
- findChild (QName "endnoteReference" (lookup "w" ns) (Just "w")) element >>=
- findAttr (QName "id" (lookup "w" ns) (Just "w"))
- of
- Just s -> Just $ Endnote s
- Nothing -> Just $
- Run (elemToRunStyle ns element)
- (elemToRunElems ns element)
-elemToRun _ _ = Nothing
-
-elemToRunElem :: NameSpaces -> Element -> Maybe RunElem
-elemToRunElem ns element
- | (qName (elName element) == "t" || qName (elName element) == "delText") &&
- qURI (elName element) `elem` [(lookup "w" ns), (lookup "m" ns)] =
- Just $ TextRun (strContent element)
- | qName (elName element) == "br" &&
- qURI (elName element) `elem` [(lookup "w" ns), (lookup "m" ns)] =
- Just $ LnBrk
- | qName (elName element) == "tab" &&
- qURI (elName element) `elem` [(lookup "w" ns), (lookup "m" ns)] =
- Just $ Tab
- | otherwise = Nothing
-
-
-elemToRunElems :: NameSpaces -> Element -> [RunElem]
-elemToRunElems ns element
- | qName (elName element) == "r" &&
- qURI (elName element) `elem` [(lookup "w" ns), (lookup "m" ns)] =
- mapMaybe (elemToRunElem ns) (elChildren element)
- | otherwise = []
-
-elemToDrawing :: NameSpaces -> Element -> Maybe ParPart
-elemToDrawing ns element
- | qName (elName element) == "drawing" &&
- qURI (elName element) == (lookup "w" ns) =
- let a_ns = "http://schemas.openxmlformats.org/drawingml/2006/main"
+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
- findElement (QName "blip" (Just a_ns) (Just "a")) element
- >>= findAttr (QName "embed" (lookup "r" ns) (Just "r"))
- >>= (\s -> Just $ Drawing s)
-elemToDrawing _ _ = Nothing
+ Just $ M.fromList $ pairs
+elemToNotes _ _ _ = Nothing
-elemToMath :: NameSpaces -> Element -> Maybe OMath
-elemToMath ns element
- | qName (elName element) == "oMath" &&
- qURI (elName element) == (lookup "m" ns) =
- Just $ OMath $ mapMaybe (elemToMathElem ns) (elChildren element)
-elemToMath _ _ = 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)
-elemToBase :: NameSpaces -> Element -> Maybe Base
-elemToBase ns element
- | qName (elName element) == "e" &&
- qURI (elName element) == (lookup "m" ns) =
- Just $ Base $ mapMaybe (elemToMathElem ns) (elChildren element)
-elemToBase _ _ = 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
+
+
+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
@@ -721,225 +644,287 @@ elemToGroupStyle ns element
GroupStyle { groupChr = chr, groupPos = pos }
elemToGroupStyle _ _ = defaultGroupStyle
-elemToMathElem :: NameSpaces -> Element -> Maybe OMathElem
-elemToMathElem ns element
- | qName (elName element) == "acc" &&
- qURI (elName element) == (lookup "m" ns) = 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 <-findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
- elemToBase ns
- return $ Accent accPr base
-elemToMathElem ns element
- | qName (elName element) == "bar" &&
- qURI (elName element) == (lookup "m" ns) = do
- barPr <- 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 <-findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
- elemToBase ns
- return $ Bar barPr base
-elemToMathElem ns element
- | qName (elName element) == "box" &&
- qURI (elName element) == (lookup "m" ns) =
- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
- elemToBase ns >>=
- (\b -> Just $ Box b)
-elemToMathElem ns element
- | qName (elName element) == "borderBox" &&
- qURI (elName element) == (lookup "m" ns) =
- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
- elemToBase ns >>=
- (\b -> Just $ BorderBox b)
-elemToMathElem ns element
- | qName (elName element) == "d" &&
- qURI (elName element) == (lookup "m" ns) =
- let style = elemToDelimStyle ns element
- in
- Just $ Delimiter style $ mapMaybe (elemToBase ns) (elChildren element)
-elemToMathElem ns element
- | qName (elName element) == "eqArr" &&
- qURI (elName element) == (lookup "m" ns) =
- Just $ EquationArray
- $ mapMaybe (elemToBase ns) (elChildren element)
-elemToMathElem ns element
- | qName (elName element) == "f" &&
- qURI (elName element) == (lookup "m" ns) = do
- num <- findChild (QName "num" (lookup "m" ns) (Just "m")) element
- den <- findChild (QName "den" (lookup "m" ns) (Just "m")) element
- let numElems = mapMaybe (elemToMathElem ns) (elChildren num)
- denElems = mapMaybe (elemToMathElem ns) (elChildren den)
- return $ Fraction numElems denElems
-elemToMathElem ns element
- | qName (elName element) == "func" &&
- qURI (elName element) == (lookup "m" ns) = do
- fName <- findChild (QName "fName" (lookup "m" ns) (Just "m")) element
- base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
- elemToBase ns
- let fnElems = mapMaybe (elemToMathElem ns) (elChildren fName)
- return $ Function fnElems base
-elemToMathElem ns element
- | qName (elName element) == "groupChr" &&
- qURI (elName element) == (lookup "m" ns) =
- let style = elemToGroupStyle ns element
- in
- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
- elemToBase ns >>=
- (\b -> Just $ Group style b)
-elemToMathElem ns element
- | qName (elName element) == "limLow" &&
- qURI (elName element) == (lookup "m" ns) = do
- base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element
- >>= elemToBase ns
- lim <- findChild (QName "lim" (lookup "m" ns) (Just "m")) element
- return $ LowerLimit base (mapMaybe (elemToMathElem ns) (elChildren lim))
-elemToMathElem ns element
- | qName (elName element) == "limUpp" &&
- qURI (elName element) == (lookup "m" ns) = do
- base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element
- >>= elemToBase ns
- lim <- findChild (QName "lim" (lookup "m" ns) (Just "m")) element
- return $ UpperLimit base (mapMaybe (elemToMathElem ns) (elChildren lim))
-elemToMathElem ns element
- | qName (elName element) == "m" &&
- qURI (elName element) == (lookup "m" ns) =
- let rows = findChildren (QName "mr" (lookup "m" ns) (Just "m")) element
- bases = map (\mr -> mapMaybe (elemToBase ns) (elChildren mr)) rows
- in
- Just $ Matrix bases
-elemToMathElem ns element
- | qName (elName element) == "nary" &&
- qURI (elName element) == (lookup "m" ns) = do
- let style = elemToNAryStyle ns element
- sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=
- (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
- sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=
- (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
- base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
- elemToBase ns
- return $ NAry style sub sup base
-elemToMathElem ns element
- | qName (elName element) == "rad" &&
- qURI (elName element) == (lookup "m" ns) = do
- deg <- findChild (QName "deg" (lookup "m" ns) (Just "m")) element >>=
- (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
- base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
- elemToBase ns
- return $ Radical deg base
--- skipping for now:
--- phant
-elemToMathElem ns element
- | qName (elName element) == "sPre" &&
- qURI (elName element) == (lookup "m" ns) = do
- sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=
- (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
- sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=
- (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
- base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
- elemToBase ns
- return $ PreSubSuper sub sup base
-elemToMathElem ns element
- | qName (elName element) == "sSub" &&
- qURI (elName element) == (lookup "m" ns) = do
- base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
- elemToBase ns
- sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=
- (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
- return $ Sub base sub
-elemToMathElem ns element
- | qName (elName element) == "sSubSup" &&
- qURI (elName element) == (lookup "m" ns) = do
- base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
- elemToBase ns
- sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=
- (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
- sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=
- (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
- return $ SubSuper base sub sup
-elemToMathElem ns element
- | qName (elName element) == "sSup" &&
- qURI (elName element) == (lookup "m" ns) = do
- base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
- elemToBase ns
- sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=
- (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
- return $ Super base sup
-elemToMathElem ns element
- | qName (elName element) == "r" &&
- qURI (elName element) == (lookup "m" ns) =
- let style = [] -- placeholder
- rstyle = elemToRunStyle ns element
- relems = elemToRunElems ns element
- in
- Just $ OMathRun style $ Run rstyle relems
-elemToMathElem _ _ = Nothing
+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)
-
-elemToParPart :: NameSpaces -> Element -> Maybe ParPart
+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
- | qName (elName element) == "r" &&
- qURI (elName element) == (lookup "w" ns) =
- case findChild (QName "drawing" (lookup "w" ns) (Just "w")) element of
- Just drawingElem -> elemToDrawing ns drawingElem
- Nothing -> do
- r <- elemToRun ns element
- return $ PlainRun r
+ | 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
- | qName (elName element) == "ins" &&
- qURI (elName element) == (lookup "w" ns) = do
- cId <- findAttr (QName "id" (lookup "w" ns) (Just "w")) element
- cAuthor <- findAttr (QName "author" (lookup "w" ns) (Just "w")) element
- cDate <- findAttr (QName "date" (lookup "w" ns) (Just "w")) element
- let runs = mapMaybe (elemToRun ns) (elChildren element)
- return $ Insertion cId cAuthor cDate runs
+ | isElem ns "w" "r" element =
+ elemToRun ns element >>= (\r -> return $ PlainRun r)
elemToParPart ns element
- | qName (elName element) == "del" &&
- qURI (elName element) == (lookup "w" ns) = do
- cId <- findAttr (QName "id" (lookup "w" ns) (Just "w")) element
- cAuthor <- findAttr (QName "author" (lookup "w" ns) (Just "w")) element
- cDate <- findAttr (QName "date" (lookup "w" ns) (Just "w")) element
- let runs = mapMaybe (elemToRun ns) (elChildren element)
- return $ Deletion cId cAuthor cDate runs
+ | 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
- | qName (elName element) == "bookmarkStart" &&
- qURI (elName element) == (lookup "w" ns) = do
- bmId <- findAttr (QName "id" (lookup "w" ns) (Just "w")) element
- bmName <- findAttr (QName "name" (lookup "w" ns) (Just "w")) element
- return $ BookMark bmId bmName
+ | 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
- | qName (elName element) == "hyperlink" &&
- qURI (elName element) == (lookup "w" ns) =
- let runs = mapMaybe (elemToRun ns)
- $ findChildren (QName "r" (lookup "w" ns) (Just "w")) element
- in
- case findAttr (QName "anchor" (lookup "w" ns) (Just "w")) element of
- Just anchor ->
- Just $ InternalHyperLink anchor runs
- Nothing ->
- case findAttr (QName "id" (lookup "r" ns) (Just "r")) element of
- Just relId -> Just $ ExternalHyperLink relId runs
- Nothing -> Nothing
+ | 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
- | qName (elName element) == "oMath" &&
- qURI (elName element) == (lookup "m" ns) =
- elemToMath ns element >>=
- (\m -> Just $ PlainOMath m)
-elemToParPart _ _ = Nothing
+ | 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
-type Target = String
-type Anchor = String
-type BookMarkId = String
-type RelId = String
-type ChangeId = String
-type Author = String
-type ChangeDate = String
+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
+
+
+
+
+
+
+
+
+
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-24 12:00:38 +0000