git.iko.soy/typeable/pandoc
on master help sign in
Merge pull request #1415 from jkr/nicertype

Nicer Docx type

commit6c4345aa0bbdc963e1a1c9a9ea2a55e3682a1fa5 authorJohn MacFarlane <jgm@berkeley.edu> dateSat 12 Jul 2014, 14:06 (12 years ago) parent0756616fe2eda9
4 files changed+740−751
compare with master
unifiedsplit
pandoc.cabal+1 src/Text/Pandoc/Compat/Except.hs+27 src/Text/Pandoc/Readers/Docx.hs+42−66 src/Text/Pandoc/Readers/Docx/Parse.hs+670−685
pandoc.cabal+1
@@ -340,6 +340,7 @@ Library
340340 Text.Pandoc.Slides,
341341 Text.Pandoc.Highlighting,
342342 Text.Pandoc.Compat.Monoid,
343+ Text.Pandoc.Compat.Except,
343344 Text.Pandoc.Compat.TagSoupEntity,
344345 Paths_pandoc
345346
src/Text/Pandoc/Compat/Except.hsnew file+27
@@ -0,0 +1,27 @@
1+{-# LANGUAGE CPP #-}
2+module Text.Pandoc.Compat.Except ( ExceptT
3+ , Error(..)
4+ , runExceptT
5+ , throwError
6+ , catchError )
7+ where
8+
9+#if MIN_VERSION_mtl(2,2,1)
10+import Control.Monad.Except
11+
12+class Error a where
13+ noMsg :: a
14+ strMsg :: String -> a
15+
16+ noMsg = strMsg ""
17+ strMsg _ = noMsg
18+
19+#else
20+import Control.Monad.Error
21+type ExceptT = ErrorT
22+
23+runExceptT :: ExceptT e m a -> m (Either e a)
24+runExceptT = runErrorT
25+#endif
26+
27+
src/Text/Pandoc/Readers/Docx.hs+42−66
@@ -91,7 +91,6 @@ import Data.List (delete, isPrefixOf, (\\), intercalate)
9191import qualified Data.ByteString as BS
9292import qualified Data.ByteString.Lazy as B
9393import Data.ByteString.Base64 (encode)
94−import System.FilePath (combine)
9594import qualified Data.Map as M
9695import Control.Monad.Reader
9796import Control.Monad.State
@@ -102,8 +101,8 @@ readDocx :: ReaderOptions
102101 -> Pandoc
103102readDocx opts bytes =
104103 case archiveToDocx (toArchive bytes) of
105− Just docx -> Pandoc nullMeta (docxToBlocks opts docx)
106− Nothing -> error $ "couldn't parse docx file"
104+ Right docx -> Pandoc nullMeta (docxToBlocks opts docx)
105+ Left _ -> error $ "couldn't parse docx file"
107106
108107data DState = DState { docxAnchorMap :: M.Map String String
109108 , docxInTexSubscript :: Bool }
@@ -159,7 +158,7 @@ runStyleToContainers rPr =
159158 , if isStrike rPr then (Just Strikeout) else Nothing
160159 , if isSuperScript rPr then (Just Superscript) else Nothing
161160 , if isSubScript rPr then (Just Subscript) else Nothing
162− , underline rPr >>= (\f -> Just $ Span ("", [], [("underline", f)]))
161+ , rUnderline rPr >>= (\f -> Just $ Span ("", [], [("underline", f)]))
163162 ]
164163 in
165164 classContainers ++ formatters
@@ -259,20 +258,17 @@ runToInlines (Run rs runElems)
259258 | otherwise =
260259 return $
261260 rebuild (runStyleToContainers rs) (concatMap runElemToInlines runElems)
262−runToInlines (Footnote fnId) = do
263− (Docx _ notes _ _ _ ) <- asks docxDocument
264− case (getFootNote fnId notes) of
265− Just bodyParts -> do
266− blks <- concatMapM bodyPartToBlocks bodyParts
267− return $ [Note blks]
268− Nothing -> return [Note []]
269−runToInlines (Endnote fnId) = do
270− (Docx _ notes _ _ _ ) <- asks docxDocument
271− case (getEndNote fnId notes) of
272− Just bodyParts -> do
273− blks <- concatMapM bodyPartToBlocks bodyParts
274− return $ [Note blks]
275− Nothing -> return [Note []]
261+runToInlines (Footnote bps) =
262+ concatMapM bodyPartToBlocks bps >>= (\blks -> return [Note blks])
263+runToInlines (Endnote bps) =
264+ concatMapM bodyPartToBlocks bps >>= (\blks -> return [Note blks])
265+
266+makeDataUrl :: String -> B.ByteString -> Maybe String
267+makeDataUrl fp bs =
268+ case getMimeType fp of
269+ Just mime -> Just $ "data:" ++ mime ++ ";base64," ++
270+ toString (encode $ BS.concat $ B.toChunks bs)
271+ Nothing -> Nothing
276272
277273parPartToInlines :: ParPart -> DocxContext [Inline]
278274parPartToInlines (PlainRun r) = runToInlines r
@@ -313,22 +309,18 @@ parPartToInlines (BookMark _ anchor) =
313309 False -> anchor
314310 updateDState $ \s -> s { docxAnchorMap = M.insert anchor newAnchor anchorMap}
315311 return [Span (anchor, ["anchor"], []) []]
316−parPartToInlines (Drawing relid) = do
317− (Docx _ _ _ rels _) <- asks docxDocument
318− return $ case lookupRelationship relid rels of
319− Just target -> [Image [] (combine "word" target, "")]
320− Nothing -> [Image [] ("", "")]
312+parPartToInlines (Drawing fp bs) = do
313+ return $ case True of -- TODO: add self-contained images
314+ True -> [Image [] (fp, "")]
315+ False -> case makeDataUrl fp bs of
316+ Just d -> [Image [] (d, "")]
317+ Nothing -> [Image [] ("", "")]
321318parPartToInlines (InternalHyperLink anchor runs) = do
322319 ils <- concatMapM runToInlines runs
323320 return [Link ils ('#' : anchor, "")]
324−parPartToInlines (ExternalHyperLink relid runs) = do
325− (Docx _ _ _ rels _) <- asks docxDocument
326− rs <- concatMapM runToInlines runs
327− return $ case lookupRelationship relid rels of
328− Just target ->
329− [Link rs (target, "")]
330− Nothing ->
331− [Link rs ("", "")]
321+parPartToInlines (ExternalHyperLink target runs) = do
322+ ils <- concatMapM runToInlines runs
323+ return [Link ils (target, "")]
332324parPartToInlines (PlainOMath omath) = do
333325 s <- oMathToTexString omath
334326 return [Math InlineMath s]
@@ -450,6 +442,9 @@ oMathElemToTexString (NAry _ sub sup base) = do
450442 baseString <- baseToTexString base
451443 return $ printf "\\int_{%s}^{%s}{%s}"
452444 subString supString baseString
445+oMathElemToTexString (Phantom base) = do
446+ baseString <- baseToTexString base
447+ return $ printf "\\phantom{%s}" baseString
453448oMathElemToTexString (Radical degree base) = do
454449 degString <- concatMapM oMathElemToTexString degree
455450 baseString <- baseToTexString base
@@ -475,7 +470,6 @@ oMathElemToTexString (Super base sup) = do
475470 supString <- concatMapM oMathElemToTexString sup
476471 return $ printf "%s^{%s}" baseString supString
477472oMathElemToTexString (OMathRun _ run) = return $ stringToTex $ runToString run
478−oMathElemToTexString _ = return "[NOT IMPLEMENTED]"
479473
480474baseToTexString :: Base -> DocxContext String
481475baseToTexString (Base mathElems) =
@@ -518,9 +512,7 @@ makeHeaderAnchor blk = return blk
518512
519513parPartsToInlines :: [ParPart] -> DocxContext [Inline]
520514parPartsToInlines parparts = do
521− ils <- concatMapM parPartToInlines parparts >>=
522− -- TODO: Option for self-containted images
523− (if False then (walkM makeImagesSelfContained) else return)
515+ ils <- concatMapM parPartToInlines parparts
524516 return $ reduceList $ ils
525517
526518cellToBlocks :: Cell -> DocxContext [Block]
@@ -563,23 +555,21 @@ bodyPartToBlocks (Paragraph pPr parparts) = do
563555 rebuild
564556 (parStyleToContainers pPr)
565557 [Para ils]
566−bodyPartToBlocks (ListItem pPr numId lvl parparts) = do
567− (Docx _ _ numbering _ _) <- asks docxDocument
558+bodyPartToBlocks (ListItem pPr numId lvl levelInfo parparts) = do
568559 let
569− kvs = case lookupLevel numId lvl numbering of
570− Just (_, fmt, txt, Just start) -> [ ("level", lvl)
571− , ("num-id", numId)
572− , ("format", fmt)
573− , ("text", txt)
574− , ("start", (show start))
575− ]
576−
577− Just (_, fmt, txt, Nothing) -> [ ("level", lvl)
578− , ("num-id", numId)
579− , ("format", fmt)
580− , ("text", txt)
581− ]
582− Nothing -> []
560+ kvs = case levelInfo of
561+ (_, fmt, txt, Just start) -> [ ("level", lvl)
562+ , ("num-id", numId)
563+ , ("format", fmt)
564+ , ("text", txt)
565+ , ("start", (show start))
566+ ]
567+
568+ (_, fmt, txt, Nothing) -> [ ("level", lvl)
569+ , ("num-id", numId)
570+ , ("format", fmt)
571+ , ("text", txt)
572+ ]
583573 blks <- bodyPartToBlocks (Paragraph pPr parparts)
584574 return $ [Div ("", ["list-item"], kvs) blks]
585575bodyPartToBlocks (Tbl _ _ _ []) =
@@ -622,20 +612,6 @@ rewriteLink l@(Link ils ('#':target, title)) = do
622612 Nothing -> l
623613rewriteLink il = return il
624614
625−makeImagesSelfContained :: Inline -> DocxContext Inline
626−makeImagesSelfContained i@(Image alt (uri, title)) = do
627− (Docx _ _ _ _ media) <- asks docxDocument
628− return $ case lookup uri media of
629− Just bs ->
630− case getMimeType uri of
631− Just mime ->
632− let data_uri = "data:" ++ mime ++ ";base64," ++
633− toString (encode $ BS.concat $ B.toChunks bs)
634− in
635− Image alt (data_uri, title)
636− Nothing -> i
637− Nothing -> i
638−makeImagesSelfContained inline = return inline
639615
640616bodyToBlocks :: Body -> DocxContext [Block]
641617bodyToBlocks (Body bps) = do
@@ -646,7 +622,7 @@ bodyToBlocks (Body bps) = do
646622 blocksToBullets $ blks
647623
648624docxToBlocks :: ReaderOptions -> Docx -> [Block]
649−docxToBlocks opts d@(Docx (Document _ body) _ _ _ _) =
625+docxToBlocks opts d@(Docx (Document _ body)) =
650626 let dState = DState { docxAnchorMap = M.empty
651627 , docxInTexSubscript = False}
652628 dEnv = DEnv { docxOptions = opts
src/Text/Pandoc/Readers/Docx/Parse.hs+670−685
@@ -10,59 +10,55 @@ the Free Software Foundation; either version 2 of the License, or
1010
1111This program is distributed in the hope that it will be useful,
1212but WITHOUT ANY WARRANTY; without even the implied warranty of
13−MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1414GNU General Public License for more details.
1515
1616You should have received a copy of the GNU General Public License
1717along with this program; if not, write to the Free Software
18−Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
18+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
1919-}
2020
2121{- |
22− Module : Text.Pandoc.Readers.Docx.Parse
23− Copyright : Copyright (C) 2014 Jesse Rosenthal
24− License : GNU GPL, version 2 or above
22+ Module : Text.Pandoc.Readers.Docx.Parse
23+ Copyright : Copyright (C) 2014 Jesse Rosenthal
24+ License : GNU GPL, version 2 or above
2525
26− Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
27− Stability : alpha
28− Portability : portable
26+ Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
27+ Stability : alpha
28+ Portability : portable
2929
3030Conversion of docx archive into Docx haskell type
3131-}
3232
33+module Text.Pandoc.Readers.Docx.Parse ( Docx(..)
34+ , Document(..)
35+ , Body(..)
36+ , BodyPart(..)
37+ , TblLook(..)
38+ , ParPart(..)
39+ , OMath(..)
40+ , OMathElem(..)
41+ , Base(..)
42+ , TopBottom(..)
43+ , AccentStyle(..)
44+ , BarStyle(..)
45+ , NAryStyle(..)
46+ , DelimStyle(..)
47+ , GroupStyle(..)
48+ , Run(..)
49+ , RunElem(..)
50+ , Notes
51+ , Numbering
52+ , Relationship
53+ , Media
54+ , RunStyle(..)
55+ , ParIndentation(..)
56+ , ParagraphStyle(..)
57+ , Row(..)
58+ , Cell(..)
59+ , archiveToDocx
60+ ) where
3361
34−module Text.Pandoc.Readers.Docx.Parse ( Docx(..)
35− , Document(..)
36− , Body(..)
37− , BodyPart(..)
38− , TblLook(..)
39− , ParPart(..)
40− , OMath(..)
41− , OMathElem(..)
42− , Base(..)
43− , TopBottom(..)
44− , AccentStyle(..)
45− , BarStyle(..)
46− , NAryStyle(..)
47− , DelimStyle(..)
48− , GroupStyle(..)
49− , Run(..)
50− , RunElem(..)
51− , Notes
52− , Numbering
53− , Relationship
54− , Media
55− , RunStyle(..)
56− , ParIndentation(..)
57− , ParagraphStyle(..)
58− , Row(..)
59− , Cell(..)
60− , getFootNote
61− , getEndNote
62− , lookupLevel
63− , lookupRelationship
64− , archiveToDocx
65− ) where
6662import Codec.Archive.Zip
6763import Text.XML.Light
6864import Data.Maybe
@@ -71,56 +67,53 @@ import System.FilePath
7167import Data.Bits ((.|.))
7268import qualified Data.ByteString.Lazy as B
7369import qualified Text.Pandoc.UTF8 as UTF8
70+import Control.Monad.Reader
71+import qualified Data.Map as M
72+import Text.Pandoc.Compat.Except
73+
74+data ReaderEnv = ReaderEnv { envNotes :: Notes
75+ , envNumbering :: Numbering
76+ , envRelationships :: [Relationship]
77+ , envMedia :: Media
78+ }
79+ deriving Show
7480
75−attrToNSPair :: Attr -> Maybe (String, String)
76−attrToNSPair (Attr (QName s _ (Just "xmlns")) val) = Just (s, val)
77−attrToNSPair _ = Nothing
81+data DocxError = DocxError | WrongElem
82+ deriving Show
83+
84+instance Error DocxError where
85+ noMsg = WrongElem
86+
87+type D = ExceptT DocxError (Reader ReaderEnv)
88+
89+runD :: D a -> ReaderEnv -> Either DocxError a
90+runD dx re = runReader (runExceptT dx ) re
91+
92+maybeToD :: Maybe a -> D a
93+maybeToD (Just a) = return a
94+maybeToD Nothing = throwError DocxError
95+
96+mapD :: (a -> D b) -> [a] -> D [b]
97+mapD _ [] = return []
98+mapD f (x:xs) = do
99+ y <- (f x >>= (\z -> return [z])) `catchError` (\_ -> return [])
100+ ys <- mapD f xs
101+ return $ y ++ ys
78102
79103
80104type NameSpaces = [(String, String)]
81105
82−data Docx = Docx Document Notes Numbering [Relationship] Media
106+data Docx = Docx Document
83107 deriving Show
84108
85−archiveToDocx :: Archive -> Maybe Docx
86−archiveToDocx archive = do
87− let notes = archiveToNotes archive
88− rels = archiveToRelationships archive
89− media = archiveToMedia archive
90− doc <- archiveToDocument archive
91− numbering <- archiveToNumbering archive
92− return $ Docx doc notes numbering rels media
93−
94109data Document = Document NameSpaces Body
95110 deriving Show
96111
97−archiveToDocument :: Archive -> Maybe Document
98−archiveToDocument zf = do
99− entry <- findEntryByPath "word/document.xml" zf
100− docElem <- (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry
101− let namespaces = mapMaybe attrToNSPair (elAttribs docElem)
102− bodyElem <- findChild (QName "body" (lookup "w" namespaces) Nothing) docElem
103− body <- elemToBody namespaces bodyElem
104− return $ Document namespaces body
112+data Body = Body [BodyPart]
113+ deriving Show
105114
106115type Media = [(FilePath, B.ByteString)]
107116
108−filePathIsMedia :: FilePath -> Bool
109−filePathIsMedia fp =
110− let (dir, _) = splitFileName fp
111− in
112− (dir == "word/media/")
113−
114−getMediaPair :: Archive -> FilePath -> Maybe (FilePath, B.ByteString)
115−getMediaPair zf fp =
116− case findEntryByPath fp zf of
117− Just e -> Just (fp, fromEntry e)
118− Nothing -> Nothing
119−
120−archiveToMedia :: Archive -> Media
121−archiveToMedia zf =
122− mapMaybe (getMediaPair zf) (filter filePathIsMedia (filesInArchive zf))
123−
124117data Numbering = Numbering NameSpaces [Numb] [AbstractNumb]
125118 deriving Show
126119
@@ -133,240 +126,12 @@ data AbstractNumb = AbstractNumb String [Level]
133126-- (ilvl, format, string, start)
134127type Level = (String, String, String, Maybe Integer)
135128
136−lookupLevel :: String -> String -> Numbering -> Maybe Level
137−lookupLevel numId ilvl (Numbering _ numbs absNumbs) = do
138− absNumId <- lookup numId $ map (\(Numb nid absnumid) -> (nid, absnumid)) numbs
139− lvls <- lookup absNumId $ map (\(AbstractNumb aid ls) -> (aid, ls)) absNumbs
140− lvl <- lookup ilvl $ map (\l@(i, _, _, _) -> (i, l)) lvls
141− return lvl
142−
143−numElemToNum :: NameSpaces -> Element -> Maybe Numb
144−numElemToNum ns element |
145− qName (elName element) == "num" &&
146− qURI (elName element) == (lookup "w" ns) = do
147− numId <- findAttr (QName "numId" (lookup "w" ns) (Just "w")) element
148− absNumId <- findChild (QName "abstractNumId" (lookup "w" ns) (Just "w")) element
149− >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
150− return $ Numb numId absNumId
151−numElemToNum _ _ = Nothing
152−
153−absNumElemToAbsNum :: NameSpaces -> Element -> Maybe AbstractNumb
154−absNumElemToAbsNum ns element |
155− qName (elName element) == "abstractNum" &&
156− qURI (elName element) == (lookup "w" ns) = do
157− absNumId <- findAttr
158− (QName "abstractNumId" (lookup "w" ns) (Just "w"))
159− element
160− let levelElems = findChildren
161− (QName "lvl" (lookup "w" ns) (Just "w"))
162− element
163− levels = mapMaybe (levelElemToLevel ns) levelElems
164− return $ AbstractNumb absNumId levels
165−absNumElemToAbsNum _ _ = Nothing
166−
167−levelElemToLevel :: NameSpaces -> Element -> Maybe Level
168−levelElemToLevel ns element |
169− qName (elName element) == "lvl" &&
170− qURI (elName element) == (lookup "w" ns) = do
171− ilvl <- findAttr (QName "ilvl" (lookup "w" ns) (Just "w")) element
172− fmt <- findChild (QName "numFmt" (lookup "w" ns) (Just "w")) element
173− >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
174− txt <- findChild (QName "lvlText" (lookup "w" ns) (Just "w")) element
175− >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
176− let start = findChild (QName "start" (lookup "w" ns) (Just "w")) element
177− >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
178− >>= (\s -> listToMaybe (map fst (reads s :: [(Integer, String)])))
179− return (ilvl, fmt, txt, start)
180−levelElemToLevel _ _ = Nothing
181−
182−archiveToNumbering :: Archive -> Maybe Numbering
183−archiveToNumbering zf =
184− case findEntryByPath "word/numbering.xml" zf of
185− Nothing -> Just $ Numbering [] [] []
186− Just entry -> do
187− numberingElem <- (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry
188− let namespaces = mapMaybe attrToNSPair (elAttribs numberingElem)
189− numElems = findChildren
190− (QName "num" (lookup "w" namespaces) (Just "w"))
191− numberingElem
192− absNumElems = findChildren
193− (QName "abstractNum" (lookup "w" namespaces) (Just "w"))
194− numberingElem
195− nums = mapMaybe (numElemToNum namespaces) numElems
196− absNums = mapMaybe (absNumElemToAbsNum namespaces) absNumElems
197− return $ Numbering namespaces nums absNums
198−
199−data Notes = Notes NameSpaces (Maybe [(String, [BodyPart])]) (Maybe [(String, [BodyPart])])
200− deriving Show
201−
202−noteElemToNote :: NameSpaces -> Element -> Maybe (String, [BodyPart])
203−noteElemToNote ns element
204− | qName (elName element) `elem` ["endnote", "footnote"] &&
205− qURI (elName element) == (lookup "w" ns) =
206− do
207− noteId <- findAttr (QName "id" (lookup "w" ns) (Just "w")) element
208− let bps = mapMaybe (elemToBodyPart ns)
209− $ elChildren element
210− return $ (noteId, bps)
211−noteElemToNote _ _ = Nothing
212−
213−getFootNote :: String -> Notes -> Maybe [BodyPart]
214−getFootNote s (Notes _ fns _) = fns >>= (lookup s)
215−
216−getEndNote :: String -> Notes -> Maybe [BodyPart]
217−getEndNote s (Notes _ _ ens) = ens >>= (lookup s)
218−
219−elemToNotes :: NameSpaces -> String -> Element -> Maybe [(String, [BodyPart])]
220−elemToNotes ns notetype element
221− | qName (elName element) == (notetype ++ "s") &&
222− qURI (elName element) == (lookup "w" ns) =
223− Just $ mapMaybe (noteElemToNote ns)
224− $ findChildren (QName notetype (lookup "w" ns) (Just "w")) element
225−elemToNotes _ _ _ = Nothing
226−
227−archiveToNotes :: Archive -> Notes
228−archiveToNotes zf =
229− let fnElem = findEntryByPath "word/footnotes.xml" zf
230− >>= (parseXMLDoc . UTF8.toStringLazy . fromEntry)
231− enElem = findEntryByPath "word/endnotes.xml" zf
232− >>= (parseXMLDoc . UTF8.toStringLazy . fromEntry)
233− fn_namespaces = case fnElem of
234− Just e -> mapMaybe attrToNSPair (elAttribs e)
235− Nothing -> []
236− en_namespaces = case enElem of
237− Just e -> mapMaybe attrToNSPair (elAttribs e)
238− Nothing -> []
239− ns = unionBy (\x y -> fst x == fst y) fn_namespaces en_namespaces
240− fn = fnElem >>= (elemToNotes ns "footnote")
241− en = enElem >>= (elemToNotes ns "endnote")
242− in
243− Notes ns fn en
244−
245−
246129data Relationship = Relationship (RelId, Target)
247130 deriving Show
248−
249−lookupRelationship :: RelId -> [Relationship] -> Maybe Target
250−lookupRelationship relid rels =
251− lookup relid (map (\(Relationship pair) -> pair) rels)
252−
253−filePathIsRel :: FilePath -> Bool
254−filePathIsRel fp =
255− let (dir, name) = splitFileName fp
256− in
257− (dir == "word/_rels/") && ((takeExtension name) == ".rels")
258−
259−relElemToRelationship :: Element -> Maybe Relationship
260−relElemToRelationship element | qName (elName element) == "Relationship" =
261− do
262− relId <- findAttr (QName "Id" Nothing Nothing) element
263− target <- findAttr (QName "Target" Nothing Nothing) element
264− return $ Relationship (relId, target)
265−relElemToRelationship _ = Nothing
266−
267−
268−archiveToRelationships :: Archive -> [Relationship]
269−archiveToRelationships archive =
270− let relPaths = filter filePathIsRel (filesInArchive archive)
271− entries = mapMaybe (\f -> findEntryByPath f archive) relPaths
272− relElems = mapMaybe (parseXMLDoc . UTF8.toStringLazy . fromEntry) entries
273− rels = mapMaybe relElemToRelationship $ concatMap elChildren relElems
274− in
275− rels
276−
277−data Body = Body [BodyPart]
278− deriving Show
279−
280−elemToBody :: NameSpaces -> Element -> Maybe Body
281−elemToBody ns element | qName (elName element) == "body" && qURI (elName element) == (lookup "w" ns) =
282− Just $ Body
283− $ mapMaybe (elemToBodyPart ns) $ elChildren element
284−elemToBody _ _ = Nothing
285−
286−elemToNumInfo :: NameSpaces -> Element -> Maybe (String, String)
287−elemToNumInfo ns element
288− | qName (elName element) == "p" &&
289− qURI (elName element) == (lookup "w" ns) =
290− do
291− pPr <- findChild (QName "pPr" (lookup "w" ns) (Just "w")) element
292− numPr <- findChild (QName "numPr" (lookup "w" ns) (Just "w")) pPr
293− lvl <- findChild (QName "ilvl" (lookup "w" ns) (Just "w")) numPr >>=
294− findAttr (QName "val" (lookup "w" ns) (Just "w"))
295− numId <- findChild (QName "numId" (lookup "w" ns) (Just "w")) numPr >>=
296− findAttr (QName "val" (lookup "w" ns) (Just "w"))
297− return (numId, lvl)
298−elemToNumInfo _ _ = Nothing
299−
300−elemToBodyPart :: NameSpaces -> Element -> Maybe BodyPart
301−elemToBodyPart ns element
302− | qName (elName element) == "p" &&
303− qURI (elName element) == (lookup "w" ns)
304− , (c:_) <- findChildren (QName "oMathPara" (lookup "m" ns) (Just "m")) element =
305− let style = [] -- placeholder
306− maths = mapMaybe (elemToMath ns)
307− $ findChildren
308− (QName "oMath" (lookup "m" ns) (Just "m")) c
309− in
310− Just $ OMathPara style maths
311− | qName (elName element) == "p" &&
312− qURI (elName element) == (lookup "w" ns)
313− , Just (numId, lvl) <- elemToNumInfo ns element =
314− let parstyle = elemToParagraphStyle ns element
315− parparts = mapMaybe (elemToParPart ns)
316− $ elChildren element
317− in
318− Just $ ListItem parstyle numId lvl parparts
319− | qName (elName element) == "p" &&
320− qURI (elName element) == (lookup "w" ns) =
321− let parstyle = elemToParagraphStyle ns element
322− parparts = mapMaybe (elemToParPart ns)
323− $ elChildren element
324− in
325− Just $ Paragraph parstyle parparts
326− | qName (elName element) == "tbl" &&
327− qURI (elName element) == (lookup "w" ns) =
328− let
329− caption = findChild (QName "tblPr" (lookup "w" ns) (Just "w")) element
330− >>= findChild (QName "tblCaption" (lookup "w" ns) (Just "w"))
331− >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
332− grid = case
333− findChild (QName "tblGrid" (lookup "w" ns) (Just "w")) element
334− of
335− Just g -> elemToTblGrid ns g
336− Nothing -> []
337− tblLook = findChild (QName "tblPr" (lookup "w" ns) (Just "w")) element
338− >>= findChild (QName "tblLook" (lookup "w" ns) (Just "w"))
339− >>= elemToTblLook ns
340− in
341− Just $ Tbl
342− (fromMaybe "" caption)
343− grid
344− (fromMaybe defaultTblLook tblLook)
345− (mapMaybe (elemToRow ns) (elChildren element))
346− | otherwise = Nothing
347−
348−elemToTblLook :: NameSpaces -> Element -> Maybe TblLook
349−elemToTblLook ns element
350− | qName (elName element) == "tblLook" &&
351− qURI (elName element) == (lookup "w" ns) =
352− let firstRow = findAttr (QName "firstRow" (lookup "w" ns) (Just "w")) element
353− val = findAttr (QName "val" (lookup "w" ns) (Just "w")) element
354− firstRowFmt =
355− case firstRow of
356− Just "1" -> True
357− Just _ -> False
358− Nothing -> case val of
359− Just bitMask -> testBitMask bitMask 0x020
360− Nothing -> False
361− in
362− Just $ TblLook{firstRowFormatting = firstRowFmt}
363−elemToTblLook _ _ = Nothing
364−
365−testBitMask :: String -> Int -> Bool
366−testBitMask bitMaskS n =
367− case (reads ("0x" ++ bitMaskS) :: [(Int, String)]) of
368− [] -> False
369− ((n', _) : _) -> ((n' .|. n) /= 0)
131+data Notes = Notes NameSpaces
132+ (Maybe (M.Map String Element))
133+ (Maybe (M.Map String Element))
134+ deriving Show
370135
371136data ParIndentation = ParIndentation { leftParIndent :: Maybe Integer
372137 , rightParIndent :: Maybe Integer
@@ -383,40 +148,9 @@ defaultParagraphStyle = ParagraphStyle { pStyle = []
383148 , indentation = Nothing
384149 }
385150
386−elemToParIndentation :: NameSpaces -> Element -> Maybe ParIndentation
387−elemToParIndentation ns element
388− | qName (elName element) == "ind" &&
389− qURI (elName element) == (lookup "w" ns) =
390− Just $ ParIndentation {
391− leftParIndent =
392− findAttr (QName "left" (lookup "w" ns) (Just "w")) element >>=
393− stringToInteger
394− , rightParIndent =
395− findAttr (QName "right" (lookup "w" ns) (Just "w")) element >>=
396− stringToInteger
397− , hangingParIndent =
398− findAttr (QName "hanging" (lookup "w" ns) (Just "w")) element >>=
399− stringToInteger}
400−elemToParIndentation _ _ = Nothing
401−
402−elemToParagraphStyle :: NameSpaces -> Element -> ParagraphStyle
403−elemToParagraphStyle ns element =
404− case findChild (QName "pPr" (lookup "w" ns) (Just "w")) element of
405− Just pPr ->
406− ParagraphStyle
407− {pStyle =
408− mapMaybe
409− (findAttr (QName "val" (lookup "w" ns) (Just "w")))
410− (findChildren (QName "pStyle" (lookup "w" ns) (Just "w")) pPr)
411− , indentation =
412− findChild (QName "ind" (lookup "w" ns) (Just "w")) pPr >>=
413− elemToParIndentation ns
414− }
415− Nothing -> defaultParagraphStyle
416−
417151
418152data BodyPart = Paragraph ParagraphStyle [ParPart]
419− | ListItem ParagraphStyle String String [ParPart]
153+ | ListItem ParagraphStyle String String Level [ParPart]
420154 | Tbl String TblGrid TblLook [Row]
421155 | OMathPara OMathParaStyle [OMath]
422156 deriving Show
@@ -429,62 +163,22 @@ data TblLook = TblLook {firstRowFormatting::Bool}
429163defaultTblLook :: TblLook
430164defaultTblLook = TblLook{firstRowFormatting = False}
431165
432−stringToInteger :: String -> Maybe Integer
433−stringToInteger s = listToMaybe $ map fst (reads s :: [(Integer, String)])
434−
435−elemToTblGrid :: NameSpaces -> Element -> TblGrid
436−elemToTblGrid ns element
437− | qName (elName element) == "tblGrid" &&
438− qURI (elName element) == (lookup "w" ns) =
439− let
440− cols = findChildren (QName "gridCol" (lookup "w" ns) (Just "w")) element
441− in
442− mapMaybe (\e ->
443− findAttr (QName "val" (lookup "w" ns) (Just ("w"))) e
444− >>= stringToInteger
445− )
446− cols
447−elemToTblGrid _ _ = []
448−
449166data Row = Row [Cell]
450167 deriving Show
451168
452−
453−elemToRow :: NameSpaces -> Element -> Maybe Row
454−elemToRow ns element
455− | qName (elName element) == "tr" &&
456− qURI (elName element) == (lookup "w" ns) =
457− let
458− cells = findChildren (QName "tc" (lookup "w" ns) (Just "w")) element
459− in
460− Just $ Row (mapMaybe (elemToCell ns) cells)
461−elemToRow _ _ = Nothing
462−
463169data Cell = Cell [BodyPart]
464170 deriving Show
465171
466−elemToCell :: NameSpaces -> Element -> Maybe Cell
467−elemToCell ns element
468− | qName (elName element) == "tc" &&
469− qURI (elName element) == (lookup "w" ns) =
470− Just $ Cell (mapMaybe (elemToBodyPart ns) (elChildren element))
471−elemToCell _ _ = Nothing
472−
473172data ParPart = PlainRun Run
474173 | Insertion ChangeId Author ChangeDate [Run]
475174 | Deletion ChangeId Author ChangeDate [Run]
476175 | BookMark BookMarkId Anchor
477176 | InternalHyperLink Anchor [Run]
478− | ExternalHyperLink RelId [Run]
479− | Drawing String
177+ | ExternalHyperLink URL [Run]
178+ | Drawing FilePath B.ByteString
480179 | PlainOMath OMath
481180 deriving Show
482181
483−data Run = Run RunStyle [RunElem]
484− | Footnote String
485− | Endnote String
486− deriving Show
487−
488182data OMath = OMath [OMathElem]
489183 deriving Show
490184
@@ -554,6 +248,12 @@ defaultGroupStyle = GroupStyle {groupChr = Nothing, groupPos = Nothing}
554248
555249type OMathRunStyle = [String]
556250
251+
252+data Run = Run RunStyle [RunElem]
253+ | Footnote [BodyPart]
254+ | Endnote [BodyPart]
255+ deriving Show
256+
557257data RunElem = TextRun String | LnBrk | Tab
558258 deriving Show
559259
@@ -563,7 +263,7 @@ data RunStyle = RunStyle { isBold :: Bool
563263 , isStrike :: Bool
564264 , isSuperScript :: Bool
565265 , isSubScript :: Bool
566− , underline :: Maybe String
266+ , rUnderline :: Maybe String
567267 , rStyle :: Maybe String }
568268 deriving Show
569269
@@ -574,104 +274,327 @@ defaultRunStyle = RunStyle { isBold = False
574274 , isStrike = False
575275 , isSuperScript = False
576276 , isSubScript = False
577− , underline = Nothing
277+ , rUnderline = Nothing
578278 , rStyle = Nothing
579279 }
580280
581−elemToRunStyle :: NameSpaces -> Element -> RunStyle
582−elemToRunStyle ns element =
583− case findChild (QName "rPr" (lookup "w" ns) (Just "w")) element of
584− Just rPr ->
585− RunStyle
586− {
587− isBold = isJust $ findChild (QName "b" (lookup "w" ns) (Just "w")) rPr
588− , isItalic = isJust $ findChild (QName "i" (lookup "w" ns) (Just "w")) rPr
589− , isSmallCaps = isJust $ findChild (QName "smallCaps" (lookup "w" ns) (Just "w")) rPr
590− , isStrike = isJust $ findChild (QName "strike" (lookup "w" ns) (Just "w")) rPr
591− , isSuperScript =
592− (Just "superscript" ==
593− (findChild (QName "vertAlign" (lookup "w" ns) (Just "w")) rPr >>=
594− findAttr (QName "val" (lookup "w" ns) (Just "w"))))
595− , isSubScript =
596− (Just "subscript" ==
597− (findChild (QName "vertAlign" (lookup "w" ns) (Just "w")) rPr >>=
598− findAttr (QName "val" (lookup "w" ns) (Just "w"))))
599− , underline =
600− findChild (QName "u" (lookup "w" ns) (Just "w")) rPr >>=
601− findAttr (QName "val" (lookup "w" ns) (Just "w"))
602− , rStyle =
603− findChild (QName "rStyle" (lookup "w" ns) (Just "w")) rPr >>=
604− findAttr (QName "val" (lookup "w" ns) (Just "w"))
605− }
606− Nothing -> defaultRunStyle
607281
608−elemToRun :: NameSpaces -> Element -> Maybe Run
609−elemToRun ns element
610− | qName (elName element) == "r" &&
611− qURI (elName element) == (lookup "w" ns) =
612− case
613− findChild (QName "footnoteReference" (lookup "w" ns) (Just "w")) element >>=
614− findAttr (QName "id" (lookup "w" ns) (Just "w"))
615− of
616− Just s -> Just $ Footnote s
617− Nothing ->
618− case
619− findChild (QName "endnoteReference" (lookup "w" ns) (Just "w")) element >>=
620− findAttr (QName "id" (lookup "w" ns) (Just "w"))
621− of
622− Just s -> Just $ Endnote s
623− Nothing -> Just $
624− Run (elemToRunStyle ns element)
625− (elemToRunElems ns element)
626−elemToRun _ _ = Nothing
627−
628−elemToRunElem :: NameSpaces -> Element -> Maybe RunElem
629−elemToRunElem ns element
630− | (qName (elName element) == "t" || qName (elName element) == "delText") &&
631− qURI (elName element) `elem` [(lookup "w" ns), (lookup "m" ns)] =
632− Just $ TextRun (strContent element)
633− | qName (elName element) == "br" &&
634− qURI (elName element) `elem` [(lookup "w" ns), (lookup "m" ns)] =
635− Just $ LnBrk
636− | qName (elName element) == "tab" &&
637− qURI (elName element) `elem` [(lookup "w" ns), (lookup "m" ns)] =
638− Just $ Tab
639− | otherwise = Nothing
640−
641−
642−elemToRunElems :: NameSpaces -> Element -> [RunElem]
643−elemToRunElems ns element
644− | qName (elName element) == "r" &&
645− qURI (elName element) `elem` [(lookup "w" ns), (lookup "m" ns)] =
646− mapMaybe (elemToRunElem ns) (elChildren element)
647− | otherwise = []
648−
649−elemToDrawing :: NameSpaces -> Element -> Maybe ParPart
650−elemToDrawing ns element
651− | qName (elName element) == "drawing" &&
652− qURI (elName element) == (lookup "w" ns) =
653− let a_ns = "http://schemas.openxmlformats.org/drawingml/2006/main"
282+type Target = String
283+type Anchor = String
284+type URL = String
285+type BookMarkId = String
286+type RelId = String
287+type ChangeId = String
288+type Author = String
289+type ChangeDate = String
290+
291+attrToNSPair :: Attr -> Maybe (String, String)
292+attrToNSPair (Attr (QName s _ (Just "xmlns")) val) = Just (s, val)
293+attrToNSPair _ = Nothing
294+
295+archiveToDocx :: Archive -> Either DocxError Docx
296+archiveToDocx archive = do
297+ let notes = archiveToNotes archive
298+ numbering = archiveToNumbering archive
299+ rels = archiveToRelationships archive
300+ media = archiveToMedia archive
301+ rEnv = ReaderEnv notes numbering rels media
302+ doc <- runD (archiveToDocument archive) rEnv
303+ return $ Docx doc
304+
305+
306+archiveToDocument :: Archive -> D Document
307+archiveToDocument zf = do
308+ entry <- maybeToD $ findEntryByPath "word/document.xml" zf
309+ docElem <- maybeToD $ (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry
310+ let namespaces = mapMaybe attrToNSPair (elAttribs docElem)
311+ bodyElem <- maybeToD $ findChild (elemName namespaces "w" "body") docElem
312+ body <- elemToBody namespaces bodyElem
313+ return $ Document namespaces body
314+
315+elemToBody :: NameSpaces -> Element -> D Body
316+elemToBody ns element | isElem ns "w" "body" element =
317+ mapD (elemToBodyPart ns) (elChildren element) >>=
318+ (\bps -> return $ Body bps)
319+elemToBody _ _ = throwError WrongElem
320+
321+archiveToNotes :: Archive -> Notes
322+archiveToNotes zf =
323+ let fnElem = findEntryByPath "word/footnotes.xml" zf
324+ >>= (parseXMLDoc . UTF8.toStringLazy . fromEntry)
325+ enElem = findEntryByPath "word/endnotes.xml" zf
326+ >>= (parseXMLDoc . UTF8.toStringLazy . fromEntry)
327+ fn_namespaces = case fnElem of
328+ Just e -> mapMaybe attrToNSPair (elAttribs e)
329+ Nothing -> []
330+ en_namespaces = case enElem of
331+ Just e -> mapMaybe attrToNSPair (elAttribs e)
332+ Nothing -> []
333+ ns = unionBy (\x y -> fst x == fst y) fn_namespaces en_namespaces
334+ fn = fnElem >>= (elemToNotes ns "footnote")
335+ en = enElem >>= (elemToNotes ns "endnote")
336+ in
337+ Notes ns fn en
338+
339+filePathIsRel :: FilePath -> Bool
340+filePathIsRel fp =
341+ let (dir, name) = splitFileName fp
342+ in
343+ (dir == "word/_rels/") && ((takeExtension name) == ".rels")
344+
345+relElemToRelationship :: Element -> Maybe Relationship
346+relElemToRelationship element | qName (elName element) == "Relationship" =
347+ do
348+ relId <- findAttr (QName "Id" Nothing Nothing) element
349+ target <- findAttr (QName "Target" Nothing Nothing) element
350+ return $ Relationship (relId, target)
351+relElemToRelationship _ = Nothing
352+
353+
354+archiveToRelationships :: Archive -> [Relationship]
355+archiveToRelationships archive =
356+ let relPaths = filter filePathIsRel (filesInArchive archive)
357+ entries = mapMaybe (\f -> findEntryByPath f archive) relPaths
358+ relElems = mapMaybe (parseXMLDoc . UTF8.toStringLazy . fromEntry) entries
359+ rels = mapMaybe relElemToRelationship $ concatMap elChildren relElems
360+ in
361+ rels
362+
363+filePathIsMedia :: FilePath -> Bool
364+filePathIsMedia fp =
365+ let (dir, _) = splitFileName fp
366+ in
367+ (dir == "word/media/")
368+
369+getMediaPair :: Archive -> FilePath -> Maybe (FilePath, B.ByteString)
370+getMediaPair zf fp =
371+ case findEntryByPath fp zf of
372+ Just e -> Just (fp, fromEntry e)
373+ Nothing -> Nothing
374+
375+archiveToMedia :: Archive -> Media
376+archiveToMedia zf =
377+ mapMaybe (getMediaPair zf) (filter filePathIsMedia (filesInArchive zf))
378+
379+lookupLevel :: String -> String -> Numbering -> Maybe Level
380+lookupLevel numId ilvl (Numbering _ numbs absNumbs) = do
381+ absNumId <- lookup numId $ map (\(Numb nid absnumid) -> (nid, absnumid)) numbs
382+ lvls <- lookup absNumId $ map (\(AbstractNumb aid ls) -> (aid, ls)) absNumbs
383+ lvl <- lookup ilvl $ map (\l@(i, _, _, _) -> (i, l)) lvls
384+ return lvl
385+
386+numElemToNum :: NameSpaces -> Element -> Maybe Numb
387+numElemToNum ns element |
388+ qName (elName element) == "num" &&
389+ qURI (elName element) == (lookup "w" ns) = do
390+ numId <- findAttr (QName "numId" (lookup "w" ns) (Just "w")) element
391+ absNumId <- findChild (QName "abstractNumId" (lookup "w" ns) (Just "w")) element
392+ >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
393+ return $ Numb numId absNumId
394+numElemToNum _ _ = Nothing
395+
396+absNumElemToAbsNum :: NameSpaces -> Element -> Maybe AbstractNumb
397+absNumElemToAbsNum ns element |
398+ qName (elName element) == "abstractNum" &&
399+ qURI (elName element) == (lookup "w" ns) = do
400+ absNumId <- findAttr
401+ (QName "abstractNumId" (lookup "w" ns) (Just "w"))
402+ element
403+ let levelElems = findChildren
404+ (QName "lvl" (lookup "w" ns) (Just "w"))
405+ element
406+ levels = mapMaybe (levelElemToLevel ns) levelElems
407+ return $ AbstractNumb absNumId levels
408+absNumElemToAbsNum _ _ = Nothing
409+
410+levelElemToLevel :: NameSpaces -> Element -> Maybe Level
411+levelElemToLevel ns element |
412+ qName (elName element) == "lvl" &&
413+ qURI (elName element) == (lookup "w" ns) = do
414+ ilvl <- findAttr (QName "ilvl" (lookup "w" ns) (Just "w")) element
415+ fmt <- findChild (QName "numFmt" (lookup "w" ns) (Just "w")) element
416+ >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
417+ txt <- findChild (QName "lvlText" (lookup "w" ns) (Just "w")) element
418+ >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
419+ let start = findChild (QName "start" (lookup "w" ns) (Just "w")) element
420+ >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
421+ >>= (\s -> listToMaybe (map fst (reads s :: [(Integer, String)])))
422+ return (ilvl, fmt, txt, start)
423+levelElemToLevel _ _ = Nothing
424+
425+archiveToNumbering' :: Archive -> Maybe Numbering
426+archiveToNumbering' zf = do
427+ case findEntryByPath "word/numbering.xml" zf of
428+ Nothing -> Just $ Numbering [] [] []
429+ Just entry -> do
430+ numberingElem <- (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry
431+ let namespaces = mapMaybe attrToNSPair (elAttribs numberingElem)
432+ numElems = findChildren
433+ (QName "num" (lookup "w" namespaces) (Just "w"))
434+ numberingElem
435+ absNumElems = findChildren
436+ (QName "abstractNum" (lookup "w" namespaces) (Just "w"))
437+ numberingElem
438+ nums = mapMaybe (numElemToNum namespaces) numElems
439+ absNums = mapMaybe (absNumElemToAbsNum namespaces) absNumElems
440+ return $ Numbering namespaces nums absNums
441+
442+archiveToNumbering :: Archive -> Numbering
443+archiveToNumbering archive =
444+ fromMaybe (Numbering [] [] []) (archiveToNumbering' archive)
445+
446+elemToNotes :: NameSpaces -> String -> Element -> Maybe (M.Map String Element)
447+elemToNotes ns notetype element
448+ | isElem ns "w" (notetype ++ "s") element =
449+ let pairs = mapMaybe
450+ (\e -> findAttr (elemName ns "w" "id") e >>=
451+ (\a -> Just (a, e)))
452+ (findChildren (elemName ns "w" notetype) element)
654453 in
655− findElement (QName "blip" (Just a_ns) (Just "a")) element
656− >>= findAttr (QName "embed" (lookup "r" ns) (Just "r"))
657− >>= (\s -> Just $ Drawing s)
658−elemToDrawing _ _ = Nothing
454+ Just $ M.fromList $ pairs
455+elemToNotes _ _ _ = Nothing
659456
660−elemToMath :: NameSpaces -> Element -> Maybe OMath
661−elemToMath ns element
662− | qName (elName element) == "oMath" &&
663− qURI (elName element) == (lookup "m" ns) =
664− Just $ OMath $ mapMaybe (elemToMathElem ns) (elChildren element)
665−elemToMath _ _ = Nothing
457+---------------------------------------------
458+---------------------------------------------
666459
460+elemName :: NameSpaces -> String -> String -> QName
461+elemName ns prefix name = (QName name (lookup prefix ns) (Just prefix))
667462
463+isElem :: NameSpaces -> String -> String -> Element -> Bool
464+isElem ns prefix name element =
465+ qName (elName element) == name &&
466+ qURI (elName element) == (lookup prefix ns)
668467
669−elemToBase :: NameSpaces -> Element -> Maybe Base
670−elemToBase ns element
671− | qName (elName element) == "e" &&
672− qURI (elName element) == (lookup "m" ns) =
673− Just $ Base $ mapMaybe (elemToMathElem ns) (elChildren element)
674−elemToBase _ _ = Nothing
468+
469+elemToTblGrid :: NameSpaces -> Element -> D TblGrid
470+elemToTblGrid ns element | isElem ns "w" "tblGrid" element =
471+ let cols = findChildren (elemName ns "w" "gridCol") element
472+ in
473+ mapD (\e -> maybeToD (findAttr (elemName ns "w" "val") e >>= stringToInteger))
474+ cols
475+elemToTblGrid _ _ = throwError WrongElem
476+
477+elemToTblLook :: NameSpaces -> Element -> D TblLook
478+elemToTblLook ns element | isElem ns "w" "tblLook" element =
479+ let firstRow = findAttr (elemName ns "w" "firstRow") element
480+ val = findAttr (elemName ns "w" "val") element
481+ firstRowFmt =
482+ case firstRow of
483+ Just "1" -> True
484+ Just _ -> False
485+ Nothing -> case val of
486+ Just bitMask -> testBitMask bitMask 0x020
487+ Nothing -> False
488+ in
489+ return $ TblLook{firstRowFormatting = firstRowFmt}
490+elemToTblLook _ _ = throwError WrongElem
491+
492+elemToRow :: NameSpaces -> Element -> D Row
493+elemToRow ns element | isElem ns "w" "tr" element =
494+ do
495+ let cellElems = findChildren (elemName ns "w" "tc") element
496+ cells <- mapD (elemToCell ns) cellElems
497+ return $ Row cells
498+elemToRow _ _ = throwError WrongElem
499+
500+elemToCell :: NameSpaces -> Element -> D Cell
501+elemToCell ns element | isElem ns "w" "tc" element =
502+ do
503+ cellContents <- mapD (elemToBodyPart ns) (elChildren element)
504+ return $ Cell cellContents
505+elemToCell _ _ = throwError WrongElem
506+
507+elemToParIndentation :: NameSpaces -> Element -> Maybe ParIndentation
508+elemToParIndentation ns element | isElem ns "w" "ind" element =
509+ Just $ ParIndentation {
510+ leftParIndent =
511+ findAttr (QName "left" (lookup "w" ns) (Just "w")) element >>=
512+ stringToInteger
513+ , rightParIndent =
514+ findAttr (QName "right" (lookup "w" ns) (Just "w")) element >>=
515+ stringToInteger
516+ , hangingParIndent =
517+ findAttr (QName "hanging" (lookup "w" ns) (Just "w")) element >>=
518+ stringToInteger}
519+elemToParIndentation _ _ = Nothing
520+
521+
522+elemToNumInfo :: NameSpaces -> Element -> Maybe (String, String)
523+elemToNumInfo ns element | isElem ns "w" "p" element = do
524+ let pPr = findChild (elemName ns "w" "pPr") element
525+ numPr = pPr >>= findChild (elemName ns "w" "numPr")
526+ lvl <- numPr >>=
527+ findChild (elemName ns "w" "ilvl") >>=
528+ findAttr (elemName ns "w" "val")
529+ numId <- numPr >>=
530+ findChild (elemName ns "w" "numId") >>=
531+ findAttr (elemName ns "w" "val")
532+ return (numId, lvl)
533+elemToNumInfo _ _ = Nothing
534+
535+testBitMask :: String -> Int -> Bool
536+testBitMask bitMaskS n =
537+ case (reads ("0x" ++ bitMaskS) :: [(Int, String)]) of
538+ [] -> False
539+ ((n', _) : _) -> ((n' .|. n) /= 0)
540+
541+stringToInteger :: String -> Maybe Integer
542+stringToInteger s = listToMaybe $ map fst (reads s :: [(Integer, String)])
543+
544+elemToBodyPart :: NameSpaces -> Element -> D BodyPart
545+elemToBodyPart ns element
546+ | isElem ns "w" "p" element
547+ , (c:_) <- findChildren (elemName ns "m" "oMathPara") element =
548+ do
549+ let style = [] -- placeholder
550+ maths <- mapD (elemToMath ns) (elChildren c)
551+ return $ OMathPara style maths
552+elemToBodyPart ns element
553+ | isElem ns "w" "p" element
554+ , Just (numId, lvl) <- elemToNumInfo ns element = do
555+ let parstyle = elemToParagraphStyle ns element
556+ parparts <- mapD (elemToParPart ns) (elChildren element)
557+ num <- asks envNumbering
558+ case lookupLevel numId lvl num of
559+ Just levelInfo -> return $ ListItem parstyle numId lvl levelInfo parparts
560+ Nothing -> throwError WrongElem
561+elemToBodyPart ns element
562+ | isElem ns "w" "p" element = do
563+ let parstyle = elemToParagraphStyle ns element
564+ parparts <- mapD (elemToParPart ns) (elChildren element)
565+ return $ Paragraph parstyle parparts
566+elemToBodyPart ns element
567+ | isElem ns "w" "tbl" element = do
568+ let caption' = findChild (elemName ns "w" "tblPr") element
569+ >>= findChild (elemName ns "w" "tblCaption")
570+ >>= findAttr (elemName ns "w" "val")
571+ caption = (fromMaybe "" caption')
572+ grid' = case findChild (elemName ns "w" "tblGrid") element of
573+ Just g -> elemToTblGrid ns g
574+ Nothing -> return []
575+ tblLook' = case findChild (elemName ns "w" "tblPr") element >>=
576+ findChild (elemName ns "w" "tblLook")
577+ of
578+ Just l -> elemToTblLook ns l
579+ Nothing -> return defaultTblLook
580+
581+ grid <- grid'
582+ tblLook <- tblLook'
583+ rows <- mapD (elemToRow ns) (elChildren element)
584+ return $ Tbl caption grid tblLook rows
585+elemToBodyPart _ _ = throwError WrongElem
586+
587+elemToMath :: NameSpaces -> Element -> D OMath
588+elemToMath ns element | isElem ns "m" "oMath" element =
589+ mapD (elemToMathElem ns) (elChildren element) >>=
590+ (\es -> return $ OMath es)
591+elemToMath _ _ = throwError WrongElem
592+
593+elemToBase :: NameSpaces -> Element -> D Base
594+elemToBase ns element | isElem ns "m" "e" element =
595+ mapD (elemToMathElem ns) (elChildren element) >>=
596+ (\es -> return $ Base es)
597+elemToBase _ _ = throwError WrongElem
675598
676599elemToNAryStyle :: NameSpaces -> Element -> NAryStyle
677600elemToNAryStyle ns element
@@ -721,225 +644,287 @@ elemToGroupStyle ns element
721644 GroupStyle { groupChr = chr, groupPos = pos }
722645elemToGroupStyle _ _ = defaultGroupStyle
723646
724−elemToMathElem :: NameSpaces -> Element -> Maybe OMathElem
725−elemToMathElem ns element
726− | qName (elName element) == "acc" &&
727− qURI (elName element) == (lookup "m" ns) = do
728− let accChar =
729− findChild (QName "accPr" (lookup "m" ns) (Just "m")) element >>=
730− findChild (QName "chr" (lookup "m" ns) (Just "m")) >>=
731− findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
732− Just . head
733− accPr = AccentStyle { accentChar = accChar}
734− base <-findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
735− elemToBase ns
736− return $ Accent accPr base
737−elemToMathElem ns element
738− | qName (elName element) == "bar" &&
739− qURI (elName element) == (lookup "m" ns) = do
740− barPr <- findChild (QName "barPr" (lookup "m" ns) (Just "m")) element >>=
741− findChild (QName "pos" (lookup "m" ns) (Just "m")) >>=
742− findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
743− (\s ->
744− Just $ BarStyle {
745− barPos = (if s == "bot" then Bottom else Top)
746− })
747− base <-findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
748− elemToBase ns
749− return $ Bar barPr base
750−elemToMathElem ns element
751− | qName (elName element) == "box" &&
752− qURI (elName element) == (lookup "m" ns) =
753− findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
754− elemToBase ns >>=
755− (\b -> Just $ Box b)
756−elemToMathElem ns element
757− | qName (elName element) == "borderBox" &&
758− qURI (elName element) == (lookup "m" ns) =
759− findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
760− elemToBase ns >>=
761− (\b -> Just $ BorderBox b)
762−elemToMathElem ns element
763− | qName (elName element) == "d" &&
764− qURI (elName element) == (lookup "m" ns) =
765− let style = elemToDelimStyle ns element
766− in
767− Just $ Delimiter style $ mapMaybe (elemToBase ns) (elChildren element)
768−elemToMathElem ns element
769− | qName (elName element) == "eqArr" &&
770− qURI (elName element) == (lookup "m" ns) =
771− Just $ EquationArray
772− $ mapMaybe (elemToBase ns) (elChildren element)
773−elemToMathElem ns element
774− | qName (elName element) == "f" &&
775− qURI (elName element) == (lookup "m" ns) = do
776− num <- findChild (QName "num" (lookup "m" ns) (Just "m")) element
777− den <- findChild (QName "den" (lookup "m" ns) (Just "m")) element
778− let numElems = mapMaybe (elemToMathElem ns) (elChildren num)
779− denElems = mapMaybe (elemToMathElem ns) (elChildren den)
780− return $ Fraction numElems denElems
781−elemToMathElem ns element
782− | qName (elName element) == "func" &&
783− qURI (elName element) == (lookup "m" ns) = do
784− fName <- findChild (QName "fName" (lookup "m" ns) (Just "m")) element
785− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
786− elemToBase ns
787− let fnElems = mapMaybe (elemToMathElem ns) (elChildren fName)
788− return $ Function fnElems base
789−elemToMathElem ns element
790− | qName (elName element) == "groupChr" &&
791− qURI (elName element) == (lookup "m" ns) =
792− let style = elemToGroupStyle ns element
793− in
794− findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
795− elemToBase ns >>=
796− (\b -> Just $ Group style b)
797−elemToMathElem ns element
798− | qName (elName element) == "limLow" &&
799− qURI (elName element) == (lookup "m" ns) = do
800− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element
801− >>= elemToBase ns
802− lim <- findChild (QName "lim" (lookup "m" ns) (Just "m")) element
803− return $ LowerLimit base (mapMaybe (elemToMathElem ns) (elChildren lim))
804−elemToMathElem ns element
805− | qName (elName element) == "limUpp" &&
806− qURI (elName element) == (lookup "m" ns) = do
807− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element
808− >>= elemToBase ns
809− lim <- findChild (QName "lim" (lookup "m" ns) (Just "m")) element
810− return $ UpperLimit base (mapMaybe (elemToMathElem ns) (elChildren lim))
811−elemToMathElem ns element
812− | qName (elName element) == "m" &&
813− qURI (elName element) == (lookup "m" ns) =
814− let rows = findChildren (QName "mr" (lookup "m" ns) (Just "m")) element
815− bases = map (\mr -> mapMaybe (elemToBase ns) (elChildren mr)) rows
816− in
817− Just $ Matrix bases
818−elemToMathElem ns element
819− | qName (elName element) == "nary" &&
820− qURI (elName element) == (lookup "m" ns) = do
821− let style = elemToNAryStyle ns element
822− sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=
823− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
824− sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=
825− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
826− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
827− elemToBase ns
828− return $ NAry style sub sup base
829−elemToMathElem ns element
830− | qName (elName element) == "rad" &&
831− qURI (elName element) == (lookup "m" ns) = do
832− deg <- findChild (QName "deg" (lookup "m" ns) (Just "m")) element >>=
833− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
834− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
835− elemToBase ns
836− return $ Radical deg base
837−-- skipping for now:
838−-- phant
839−elemToMathElem ns element
840− | qName (elName element) == "sPre" &&
841− qURI (elName element) == (lookup "m" ns) = do
842− sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=
843− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
844− sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=
845− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
846− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
847− elemToBase ns
848− return $ PreSubSuper sub sup base
849−elemToMathElem ns element
850− | qName (elName element) == "sSub" &&
851− qURI (elName element) == (lookup "m" ns) = do
852− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
853− elemToBase ns
854− sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=
855− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
856− return $ Sub base sub
857−elemToMathElem ns element
858− | qName (elName element) == "sSubSup" &&
859− qURI (elName element) == (lookup "m" ns) = do
860− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
861− elemToBase ns
862− sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=
863− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
864− sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=
865− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
866− return $ SubSuper base sub sup
867−elemToMathElem ns element
868− | qName (elName element) == "sSup" &&
869− qURI (elName element) == (lookup "m" ns) = do
870− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
871− elemToBase ns
872− sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=
873− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
874− return $ Super base sup
875−elemToMathElem ns element
876− | qName (elName element) == "r" &&
877− qURI (elName element) == (lookup "m" ns) =
878− let style = [] -- placeholder
879− rstyle = elemToRunStyle ns element
880− relems = elemToRunElems ns element
881− in
882− Just $ OMathRun style $ Run rstyle relems
883−elemToMathElem _ _ = Nothing
647+elemToMathElem :: NameSpaces -> Element -> D OMathElem
648+elemToMathElem ns element | isElem ns "m" "acc" element = do
649+ let accChar =
650+ findChild (QName "accPr" (lookup "m" ns) (Just "m")) element >>=
651+ findChild (QName "chr" (lookup "m" ns) (Just "m")) >>=
652+ findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
653+ Just . head
654+ accPr = AccentStyle { accentChar = accChar}
655+ base <-(maybeToD $ findChild (elemName ns "m" "e") element) >>=
656+ elemToBase ns
657+ return $ Accent accPr base
658+elemToMathElem ns element | isElem ns "m" "bar" element = do
659+ barPr <- maybeToD $
660+ findChild (QName "barPr" (lookup "m" ns) (Just "m")) element >>=
661+ findChild (QName "pos" (lookup "m" ns) (Just "m")) >>=
662+ findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
663+ (\s ->
664+ Just $ BarStyle {
665+ barPos = (if s == "bot" then Bottom else Top)
666+ })
667+ base <-maybeToD (findChild (QName "e" (lookup "m" ns) (Just "m")) element) >>=
668+ elemToBase ns
669+ return $ Bar barPr base
670+elemToMathElem ns element | isElem ns "m" "box" element =
671+ maybeToD (findChild (elemName ns "m" "e") element) >>=
672+ elemToBase ns >>=
673+ (\b -> return $ Box b)
674+elemToMathElem ns element | isElem ns "m" "borderBox" element =
675+ maybeToD (findChild (elemName ns "m" "e") element) >>=
676+ elemToBase ns >>=
677+ (\b -> return $ BorderBox b)
678+elemToMathElem ns element | isElem ns "m" "d" element =
679+ let style = elemToDelimStyle ns element
680+ in
681+ mapD (elemToBase ns) (elChildren element) >>=
682+ (\es -> return $ Delimiter style es)
683+elemToMathElem ns element | isElem ns "m" "eqArr" element =
684+ mapD (elemToBase ns) (elChildren element) >>=
685+ (\es -> return $ EquationArray es)
686+elemToMathElem ns element | isElem ns "m" "f" element = do
687+ num <- maybeToD $ findChild (elemName ns "m" "num") element
688+ den <- maybeToD $ findChild (elemName ns "m" "den") element
689+ numElems <- mapD (elemToMathElem ns) (elChildren num)
690+ denElems <- mapD (elemToMathElem ns) (elChildren den)
691+ return $ Fraction numElems denElems
692+elemToMathElem ns element | isElem ns "m" "func" element = do
693+ fName <- maybeToD $ findChild (elemName ns "m" "fName") element
694+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
695+ elemToBase ns
696+ fnElems <- mapD (elemToMathElem ns) (elChildren fName)
697+ return $ Function fnElems base
698+elemToMathElem ns element | isElem ns "m" "groupChr" element =
699+ let style = elemToGroupStyle ns element
700+ in
701+ maybeToD (findChild (elemName ns "m" "e") element) >>=
702+ elemToBase ns >>=
703+ (\b -> return $ Group style b)
704+elemToMathElem ns element | isElem ns "m" "limLow" element = do
705+ base <- maybeToD (findChild (elemName ns "m" "e") element)
706+ >>= elemToBase ns
707+ lim <- maybeToD $ findChild (elemName ns "m" "lim") element
708+ limElems <- mapD (elemToMathElem ns) (elChildren lim)
709+ return $ LowerLimit base limElems
710+elemToMathElem ns element | isElem ns "m" "limUpp" element = do
711+ base <- maybeToD (findChild (elemName ns "m" "e") element)
712+ >>= elemToBase ns
713+ lim <- maybeToD $ findChild (elemName ns "m" "lim") element
714+ limElems <- mapD (elemToMathElem ns) (elChildren lim)
715+ return $ UpperLimit base limElems
716+elemToMathElem ns element | isElem ns "m" "m" element = do
717+ let rows = findChildren (elemName ns "m" "mr") element
718+ bases <- mapD (\mr -> mapD (elemToBase ns) (elChildren mr)) rows
719+ return $ Matrix bases
720+elemToMathElem ns element | isElem ns "m" "nary" element = do
721+ let style = elemToNAryStyle ns element
722+ sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>=
723+ (\e -> mapD (elemToMathElem ns) (elChildren e))
724+ sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>=
725+ (\e -> mapD (elemToMathElem ns) (elChildren e))
726+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
727+ elemToBase ns
728+ return $ NAry style sub sup base
729+elemToMathElem ns element | isElem ns "m" "rad" element = do
730+ deg <- maybeToD (findChild (elemName ns "m" "deg") element) >>=
731+ (\e -> mapD (elemToMathElem ns) (elChildren e))
732+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
733+ elemToBase ns
734+ return $ Radical deg base
735+elemToMathElem ns element | isElem ns "m" "phant" element = do
736+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
737+ elemToBase ns
738+ return $ Phantom base
739+elemToMathElem ns element | isElem ns "m" "sPre" element = do
740+ sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>=
741+ (\e -> mapD (elemToMathElem ns) (elChildren e))
742+ sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>=
743+ (\e -> mapD (elemToMathElem ns) (elChildren e))
744+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
745+ elemToBase ns
746+ return $ PreSubSuper sub sup base
747+elemToMathElem ns element | isElem ns "m" "sSub" element = do
748+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
749+ elemToBase ns
750+ sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>=
751+ (\e -> mapD (elemToMathElem ns) (elChildren e))
752+ return $ Sub base sub
753+elemToMathElem ns element | isElem ns "m" "sSubSup" element = do
754+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
755+ elemToBase ns
756+ sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>=
757+ (\e -> mapD (elemToMathElem ns) (elChildren e))
758+ sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>=
759+ (\e -> mapD (elemToMathElem ns) (elChildren e))
760+ return $ SubSuper base sub sup
761+elemToMathElem ns element | isElem ns "m" "sSup" element = do
762+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
763+ elemToBase ns
764+ sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>=
765+ (\e -> mapD (elemToMathElem ns) (elChildren e))
766+ return $ Sub base sup
767+elemToMathElem ns element | isElem ns "m" "r" element = do
768+ let style = [] -- placeholder
769+ rstyle = elemToRunStyle ns element
770+ relems <- elemToRunElems ns element
771+ return $ OMathRun style $ Run rstyle relems
772+elemToMathElem _ _ = throwError WrongElem
884773
774+lookupRelationship :: RelId -> [Relationship] -> Maybe Target
775+lookupRelationship relid rels =
776+ lookup relid (map (\(Relationship pair) -> pair) rels)
885777
886−
887−elemToParPart :: NameSpaces -> Element -> Maybe ParPart
778+expandDrawingId :: String -> D ParPart
779+expandDrawingId s = do
780+ target <- asks (lookupRelationship s . envRelationships)
781+ case target of
782+ Just t -> do let filepath = combine "word" t
783+ bytes <- asks (lookup filepath . envMedia)
784+ case bytes of
785+ Just bs -> return $ Drawing filepath bs
786+ Nothing -> throwError DocxError
787+ Nothing -> throwError DocxError
788+
789+elemToParPart :: NameSpaces -> Element -> D ParPart
888790elemToParPart ns element
889− | qName (elName element) == "r" &&
890− qURI (elName element) == (lookup "w" ns) =
891− case findChild (QName "drawing" (lookup "w" ns) (Just "w")) element of
892− Just drawingElem -> elemToDrawing ns drawingElem
893− Nothing -> do
894− r <- elemToRun ns element
895− return $ PlainRun r
791+ | isElem ns "w" "r" element
792+ , Just _ <- findChild (elemName ns "w" "drawing") element =
793+ let a_ns = "http://schemas.openxmlformats.org/drawingml/2006/main"
794+ drawing = findElement (QName "blip" (Just a_ns) (Just "a")) element
795+ >>= findAttr (QName "embed" (lookup "r" ns) (Just "r"))
796+ in
797+ case drawing of
798+ Just s -> expandDrawingId s
799+ Nothing -> throwError WrongElem
896800elemToParPart ns element
897− | qName (elName element) == "ins" &&
898− qURI (elName element) == (lookup "w" ns) = do
899− cId <- findAttr (QName "id" (lookup "w" ns) (Just "w")) element
900− cAuthor <- findAttr (QName "author" (lookup "w" ns) (Just "w")) element
901− cDate <- findAttr (QName "date" (lookup "w" ns) (Just "w")) element
902− let runs = mapMaybe (elemToRun ns) (elChildren element)
903− return $ Insertion cId cAuthor cDate runs
801+ | isElem ns "w" "r" element =
802+ elemToRun ns element >>= (\r -> return $ PlainRun r)
904803elemToParPart ns element
905− | qName (elName element) == "del" &&
906− qURI (elName element) == (lookup "w" ns) = do
907− cId <- findAttr (QName "id" (lookup "w" ns) (Just "w")) element
908− cAuthor <- findAttr (QName "author" (lookup "w" ns) (Just "w")) element
909− cDate <- findAttr (QName "date" (lookup "w" ns) (Just "w")) element
910− let runs = mapMaybe (elemToRun ns) (elChildren element)
911− return $ Deletion cId cAuthor cDate runs
804+ | isElem ns "w" "ins" element
805+ , Just cId <- findAttr (elemName ns "w" "id") element
806+ , Just cAuthor <- findAttr (elemName ns "w" "author") element
807+ , Just cDate <- findAttr (elemName ns "w" "date") element = do
808+ runs <- mapD (elemToRun ns) (elChildren element)
809+ return $ Insertion cId cAuthor cDate runs
912810elemToParPart ns element
913− | qName (elName element) == "bookmarkStart" &&
914− qURI (elName element) == (lookup "w" ns) = do
915− bmId <- findAttr (QName "id" (lookup "w" ns) (Just "w")) element
916− bmName <- findAttr (QName "name" (lookup "w" ns) (Just "w")) element
917− return $ BookMark bmId bmName
811+ | isElem ns "w" "del" element
812+ , Just cId <- findAttr (elemName ns "w" "id") element
813+ , Just cAuthor <- findAttr (elemName ns "w" "author") element
814+ , Just cDate <- findAttr (elemName ns "w" "date") element = do
815+ runs <- mapD (elemToRun ns) (elChildren element)
816+ return $ Deletion cId cAuthor cDate runs
918817elemToParPart ns element
919− | qName (elName element) == "hyperlink" &&
920− qURI (elName element) == (lookup "w" ns) =
921− let runs = mapMaybe (elemToRun ns)
922− $ findChildren (QName "r" (lookup "w" ns) (Just "w")) element
923− in
924− case findAttr (QName "anchor" (lookup "w" ns) (Just "w")) element of
925− Just anchor ->
926− Just $ InternalHyperLink anchor runs
927− Nothing ->
928− case findAttr (QName "id" (lookup "r" ns) (Just "r")) element of
929− Just relId -> Just $ ExternalHyperLink relId runs
930− Nothing -> Nothing
818+ | isElem ns "w" "bookmarkStart" element
819+ , Just bmId <- findAttr (elemName ns "w" "id") element
820+ , Just bmName <- findAttr (elemName ns "w" "name") element =
821+ return $ BookMark bmId bmName
822+elemToParPart ns element
823+ | isElem ns "w" "hyperlink" element
824+ , Just anchor <- findAttr (elemName ns "w" "anchor") element = do
825+ runs <- mapD (elemToRun ns) (elChildren element)
826+ return $ InternalHyperLink anchor runs
931827elemToParPart ns element
932− | qName (elName element) == "oMath" &&
933− qURI (elName element) == (lookup "m" ns) =
934− elemToMath ns element >>=
935− (\m -> Just $ PlainOMath m)
936−elemToParPart _ _ = Nothing
828+ | isElem ns "w" "hyperlink" element
829+ , Just relId <- findAttr (elemName ns "r" "id") element = do
830+ runs <- mapD (elemToRun ns) (elChildren element)
831+ rels <- asks envRelationships
832+ return $ case lookupRelationship relId rels of
833+ Just target -> ExternalHyperLink target runs
834+ Nothing -> ExternalHyperLink "" runs
835+elemToParPart _ _ = throwError WrongElem
836+
837+lookupFootnote :: String -> Notes -> Maybe Element
838+lookupFootnote s (Notes _ fns _) = fns >>= (M.lookup s)
839+
840+lookupEndnote :: String -> Notes -> Maybe Element
841+lookupEndnote s (Notes _ _ ens) = ens >>= (M.lookup s)
842+
843+elemToRun :: NameSpaces -> Element -> D Run
844+elemToRun ns element
845+ | isElem ns "w" "r" element
846+ , Just ref <- findChild (elemName ns "w" "footnoteReference") element
847+ , Just fnId <- findAttr (elemName ns "w" "id") ref = do
848+ notes <- asks envNotes
849+ case lookupFootnote fnId notes of
850+ Just e -> do bps <- mapD (elemToBodyPart ns) (elChildren e)
851+ return $ Footnote bps
852+ Nothing -> return $ Footnote []
853+elemToRun ns element
854+ | isElem ns "w" "r" element
855+ , Just ref <- findChild (elemName ns "w" "endnoteReference") element
856+ , Just enId <- findAttr (elemName ns "w" "id") ref = do
857+ notes <- asks envNotes
858+ case lookupEndnote enId notes of
859+ Just e -> do bps <- mapD (elemToBodyPart ns) (elChildren e)
860+ return $ Footnote bps
861+ Nothing -> return $ Footnote []
862+elemToRun ns element
863+ | isElem ns "w" "r" element = do
864+ runElems <- elemToRunElems ns element
865+ return $ Run (elemToRunStyle ns element) runElems
866+elemToRun _ _ = throwError WrongElem
867+
868+elemToParagraphStyle :: NameSpaces -> Element -> ParagraphStyle
869+elemToParagraphStyle ns element
870+ | Just pPr <- findChild (elemName ns "w" "pPr") element =
871+ ParagraphStyle
872+ {pStyle =
873+ mapMaybe
874+ (findAttr (elemName ns "w" "val"))
875+ (findChildren (elemName ns "w" "pStyle") pPr)
876+ , indentation =
877+ findChild (elemName ns "w" "ind") pPr >>=
878+ elemToParIndentation ns
879+ }
880+elemToParagraphStyle _ _ = defaultParagraphStyle
937881
938882
939−type Target = String
940−type Anchor = String
941−type BookMarkId = String
942−type RelId = String
943−type ChangeId = String
944−type Author = String
945−type ChangeDate = String
883+elemToRunStyle :: NameSpaces -> Element -> RunStyle
884+elemToRunStyle ns element
885+ | Just rPr <- findChild (elemName ns "w" "rPr") element =
886+ RunStyle
887+ {
888+ isBold = isJust $ findChild (QName "b" (lookup "w" ns) (Just "w")) rPr
889+ , isItalic = isJust $ findChild (QName "i" (lookup "w" ns) (Just "w")) rPr
890+ , isSmallCaps = isJust $ findChild (QName "smallCaps" (lookup "w" ns) (Just "w")) rPr
891+ , isStrike = isJust $ findChild (QName "strike" (lookup "w" ns) (Just "w")) rPr
892+ , isSuperScript =
893+ (Just "superscript" ==
894+ (findChild (QName "vertAlign" (lookup "w" ns) (Just "w")) rPr >>=
895+ findAttr (QName "val" (lookup "w" ns) (Just "w"))))
896+ , isSubScript =
897+ (Just "subscript" ==
898+ (findChild (QName "vertAlign" (lookup "w" ns) (Just "w")) rPr >>=
899+ findAttr (QName "val" (lookup "w" ns) (Just "w"))))
900+ , rUnderline =
901+ findChild (QName "u" (lookup "w" ns) (Just "w")) rPr >>=
902+ findAttr (QName "val" (lookup "w" ns) (Just "w"))
903+ , rStyle =
904+ findChild (QName "rStyle" (lookup "w" ns) (Just "w")) rPr >>=
905+ findAttr (QName "val" (lookup "w" ns) (Just "w"))
906+ }
907+elemToRunStyle _ _ = defaultRunStyle
908+
909+elemToRunElem :: NameSpaces -> Element -> D RunElem
910+elemToRunElem ns element
911+ | isElem ns "w" "t" element || isElem ns "w" "delText" element =
912+ return $ TextRun $ strContent element
913+ | isElem ns "w" "br" element = return LnBrk
914+ | isElem ns "w" "tab" element = return Tab
915+ | otherwise = throwError WrongElem
916+
917+elemToRunElems :: NameSpaces -> Element -> D [RunElem]
918+elemToRunElems ns element
919+ | isElem ns "w" "r" element = mapD (elemToRunElem ns) (elChildren element)
920+elemToRunElems _ _ = throwError WrongElem
921+
922+
923+
924+
925+
926+
927+
928+
929+
930+