git.iko.soy/typeable/pandoc
on master help sign in
Docx Reader: A nicer Docx type.
d65fd58Jesse Rosenthal
src/Text/Pandoc/Readers/Docx.hs+42−66
compare with master
unifiedsplit
@@ -91,7 +91,6 @@ import Data.List (delete, isPrefixOf, (\\), intercalate)
91import qualified Data.ByteString as BS
91import qualified Data.ByteString as BS
92import qualified Data.ByteString.Lazy as B
92import qualified Data.ByteString.Lazy as B
93import Data.ByteString.Base64 (encode)
93import Data.ByteString.Base64 (encode)
94−import System.FilePath (combine)
95import qualified Data.Map as M
94import qualified Data.Map as M
96import Control.Monad.Reader
95import Control.Monad.Reader
97import Control.Monad.State
96import Control.Monad.State
@@ -102,8 +101,8 @@ readDocx :: ReaderOptions
102 -> Pandoc
101 -> Pandoc
103readDocx opts bytes =
102readDocx opts bytes =
104 case archiveToDocx (toArchive bytes) of
103 case archiveToDocx (toArchive bytes) of
105− Just docx -> Pandoc nullMeta (docxToBlocks opts docx)
104+ Right docx -> Pandoc nullMeta (docxToBlocks opts docx)
106− Nothing -> error $ "couldn't parse docx file"
105+ Left _ -> error $ "couldn't parse docx file"
107
106
108data DState = DState { docxAnchorMap :: M.Map String String
107data DState = DState { docxAnchorMap :: M.Map String String
109 , docxInTexSubscript :: Bool }
108 , docxInTexSubscript :: Bool }
@@ -159,7 +158,7 @@ runStyleToContainers rPr =
159 , if isStrike rPr then (Just Strikeout) else Nothing
158 , if isStrike rPr then (Just Strikeout) else Nothing
160 , if isSuperScript rPr then (Just Superscript) else Nothing
159 , if isSuperScript rPr then (Just Superscript) else Nothing
161 , if isSubScript rPr then (Just Subscript) else Nothing
160 , if isSubScript rPr then (Just Subscript) else Nothing
162− , underline rPr >>= (\f -> Just $ Span ("", [], [("underline", f)]))
161+ , rUnderline rPr >>= (\f -> Just $ Span ("", [], [("underline", f)]))
163 ]
162 ]
164 in
163 in
165 classContainers ++ formatters
164 classContainers ++ formatters
@@ -259,20 +258,17 @@ runToInlines (Run rs runElems)
259 | otherwise =
258 | otherwise =
260 return $
259 return $
261 rebuild (runStyleToContainers rs) (concatMap runElemToInlines runElems)
260 rebuild (runStyleToContainers rs) (concatMap runElemToInlines runElems)
262−runToInlines (Footnote fnId) = do
261+runToInlines (Footnote bps) =
263− (Docx _ notes _ _ _ ) <- asks docxDocument
264− case (getFootNote fnId notes) of
265− Just bodyParts -> do
266− blks <- concatMapM bodyPartToBlocks bodyParts
262+ concatMapM bodyPartToBlocks bps >>= (\blks -> return [Note blks])
267− return $ [Note blks]
268− Nothing -> return [Note []]
269−runToInlines (Endnote fnId) = do
263+runToInlines (Endnote bps) =
270− (Docx _ notes _ _ _ ) <- asks docxDocument
264+ concatMapM bodyPartToBlocks bps >>= (\blks -> return [Note blks])
271− case (getEndNote fnId notes) of
265+
272− Just bodyParts -> do
266+makeDataUrl :: String -> B.ByteString -> Maybe String
273− blks <- concatMapM bodyPartToBlocks bodyParts
267+makeDataUrl fp bs =
274− return $ [Note blks]
268+ case getMimeType fp of
269+ Just mime -> Just $ "data:" ++ mime ++ ";base64," ++
270+ toString (encode $ BS.concat $ B.toChunks bs)
275− Nothing -> return [Note []]
271+ Nothing -> Nothing
276
272
277parPartToInlines :: ParPart -> DocxContext [Inline]
273parPartToInlines :: ParPart -> DocxContext [Inline]
278parPartToInlines (PlainRun r) = runToInlines r
274parPartToInlines (PlainRun r) = runToInlines r
@@ -313,22 +309,18 @@ parPartToInlines (BookMark _ anchor) =
313 False -> anchor
309 False -> anchor
314 updateDState $ \s -> s { docxAnchorMap = M.insert anchor newAnchor anchorMap}
310 updateDState $ \s -> s { docxAnchorMap = M.insert anchor newAnchor anchorMap}
315 return [Span (anchor, ["anchor"], []) []]
311 return [Span (anchor, ["anchor"], []) []]
316−parPartToInlines (Drawing relid) = do
312+parPartToInlines (Drawing fp bs) = do
317− (Docx _ _ _ rels _) <- asks docxDocument
313+ return $ case True of -- TODO: add self-contained images
318− return $ case lookupRelationship relid rels of
314+ True -> [Image [] (fp, "")]
315+ False -> case makeDataUrl fp bs of
319− Just target -> [Image [] (combine "word" target, "")]
316+ Just d -> [Image [] (d, "")]
320− Nothing -> [Image [] ("", "")]
317+ Nothing -> [Image [] ("", "")]
321parPartToInlines (InternalHyperLink anchor runs) = do
318parPartToInlines (InternalHyperLink anchor runs) = do
322 ils <- concatMapM runToInlines runs
319 ils <- concatMapM runToInlines runs
323 return [Link ils ('#' : anchor, "")]
320 return [Link ils ('#' : anchor, "")]
324−parPartToInlines (ExternalHyperLink relid runs) = do
321+parPartToInlines (ExternalHyperLink target runs) = do
325− (Docx _ _ _ rels _) <- asks docxDocument
326− rs <- concatMapM runToInlines runs
322+ ils <- concatMapM runToInlines runs
327− return $ case lookupRelationship relid rels of
328− Just target ->
329− [Link rs (target, "")]
323+ return [Link ils (target, "")]
330− Nothing ->
331− [Link rs ("", "")]
332parPartToInlines (PlainOMath omath) = do
324parPartToInlines (PlainOMath omath) = do
333 s <- oMathToTexString omath
325 s <- oMathToTexString omath
334 return [Math InlineMath s]
326 return [Math InlineMath s]
@@ -450,6 +442,9 @@ oMathElemToTexString (NAry _ sub sup base) = do
450 baseString <- baseToTexString base
442 baseString <- baseToTexString base
451 return $ printf "\\int_{%s}^{%s}{%s}"
443 return $ printf "\\int_{%s}^{%s}{%s}"
452 subString supString baseString
444 subString supString baseString
445+oMathElemToTexString (Phantom base) = do
446+ baseString <- baseToTexString base
447+ return $ printf "\\phantom{%s}" baseString
453oMathElemToTexString (Radical degree base) = do
448oMathElemToTexString (Radical degree base) = do
454 degString <- concatMapM oMathElemToTexString degree
449 degString <- concatMapM oMathElemToTexString degree
455 baseString <- baseToTexString base
450 baseString <- baseToTexString base
@@ -475,7 +470,6 @@ oMathElemToTexString (Super base sup) = do
475 supString <- concatMapM oMathElemToTexString sup
470 supString <- concatMapM oMathElemToTexString sup
476 return $ printf "%s^{%s}" baseString supString
471 return $ printf "%s^{%s}" baseString supString
477oMathElemToTexString (OMathRun _ run) = return $ stringToTex $ runToString run
472oMathElemToTexString (OMathRun _ run) = return $ stringToTex $ runToString run
478−oMathElemToTexString _ = return "[NOT IMPLEMENTED]"
479
473
480baseToTexString :: Base -> DocxContext String
474baseToTexString :: Base -> DocxContext String
481baseToTexString (Base mathElems) =
475baseToTexString (Base mathElems) =
@@ -518,9 +512,7 @@ makeHeaderAnchor blk = return blk
518
512
519parPartsToInlines :: [ParPart] -> DocxContext [Inline]
513parPartsToInlines :: [ParPart] -> DocxContext [Inline]
520parPartsToInlines parparts = do
514parPartsToInlines parparts = do
521− ils <- concatMapM parPartToInlines parparts >>=
515+ ils <- concatMapM parPartToInlines parparts
522− -- TODO: Option for self-containted images
523− (if False then (walkM makeImagesSelfContained) else return)
524 return $ reduceList $ ils
516 return $ reduceList $ ils
525
517
526cellToBlocks :: Cell -> DocxContext [Block]
518cellToBlocks :: Cell -> DocxContext [Block]
@@ -563,23 +555,21 @@ bodyPartToBlocks (Paragraph pPr parparts) = do
563 rebuild
555 rebuild
564 (parStyleToContainers pPr)
556 (parStyleToContainers pPr)
565 [Para ils]
557 [Para ils]
566−bodyPartToBlocks (ListItem pPr numId lvl parparts) = do
558+bodyPartToBlocks (ListItem pPr numId lvl levelInfo parparts) = do
567− (Docx _ _ numbering _ _) <- asks docxDocument
568 let
559 let
569− kvs = case lookupLevel numId lvl numbering of
560+ kvs = case levelInfo of
570− Just (_, fmt, txt, Just start) -> [ ("level", lvl)
561+ (_, fmt, txt, Just start) -> [ ("level", lvl)
571− , ("num-id", numId)
562+ , ("num-id", numId)
572− , ("format", fmt)
563+ , ("format", fmt)
573− , ("text", txt)
564+ , ("text", txt)
574− , ("start", (show start))
565+ , ("start", (show start))
575− ]
566+ ]
576−
567+
577− Just (_, fmt, txt, Nothing) -> [ ("level", lvl)
568+ (_, fmt, txt, Nothing) -> [ ("level", lvl)
578− , ("num-id", numId)
569+ , ("num-id", numId)
579− , ("format", fmt)
570+ , ("format", fmt)
580− , ("text", txt)
571+ , ("text", txt)
581− ]
572+ ]
582− Nothing -> []
583 blks <- bodyPartToBlocks (Paragraph pPr parparts)
573 blks <- bodyPartToBlocks (Paragraph pPr parparts)
584 return $ [Div ("", ["list-item"], kvs) blks]
574 return $ [Div ("", ["list-item"], kvs) blks]
585bodyPartToBlocks (Tbl _ _ _ []) =
575bodyPartToBlocks (Tbl _ _ _ []) =
@@ -622,20 +612,6 @@ rewriteLink l@(Link ils ('#':target, title)) = do
622 Nothing -> l
612 Nothing -> l
623rewriteLink il = return il
613rewriteLink il = return il
624
614
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
639
615
640bodyToBlocks :: Body -> DocxContext [Block]
616bodyToBlocks :: Body -> DocxContext [Block]
641bodyToBlocks (Body bps) = do
617bodyToBlocks (Body bps) = do
@@ -646,7 +622,7 @@ bodyToBlocks (Body bps) = do
646 blocksToBullets $ blks
622 blocksToBullets $ blks
647
623
648docxToBlocks :: ReaderOptions -> Docx -> [Block]
624docxToBlocks :: ReaderOptions -> Docx -> [Block]
649−docxToBlocks opts d@(Docx (Document _ body) _ _ _ _) =
625+docxToBlocks opts d@(Docx (Document _ body)) =
650 let dState = DState { docxAnchorMap = M.empty
626 let dState = DState { docxAnchorMap = M.empty
651 , docxInTexSubscript = False}
627 , docxInTexSubscript = False}
652 dEnv = DEnv { docxOptions = opts
628 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
10
10
11This program is distributed in the hope that it will be useful,
11This program is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
12but 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
14GNU General Public License for more details.
14GNU General Public License for more details.
15
15
16You should have received a copy of the GNU General Public License
16You should have received a copy of the GNU General Public License
17along with this program; if not, write to the Free Software
17along 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
19-}
19-}
20
20
21{- |
21{- |
22− Module : Text.Pandoc.Readers.Docx.Parse
22+ Module : Text.Pandoc.Readers.Docx.Parse
23− Copyright : Copyright (C) 2014 Jesse Rosenthal
23+ Copyright : Copyright (C) 2014 Jesse Rosenthal
24− License : GNU GPL, version 2 or above
24+ License : GNU GPL, version 2 or above
25
25
26− Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
26+ Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
27− Stability : alpha
27+ Stability : alpha
28− Portability : portable
28+ Portability : portable
29
29
30Conversion of docx archive into Docx haskell type
30Conversion of docx archive into Docx haskell type
31-}
31-}
32
32
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
33
61
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
66import Codec.Archive.Zip
62import Codec.Archive.Zip
67import Text.XML.Light
63import Text.XML.Light
68import Data.Maybe
64import Data.Maybe
@@ -71,56 +67,53 @@ import System.FilePath
71import Data.Bits ((.|.))
67import Data.Bits ((.|.))
72import qualified Data.ByteString.Lazy as B
68import qualified Data.ByteString.Lazy as B
73import qualified Text.Pandoc.UTF8 as UTF8
69import qualified Text.Pandoc.UTF8 as UTF8
70+import Control.Monad.Reader
71+import qualified Data.Map as M
72+import Control.Monad.Error
73+
74+data ReaderEnv = ReaderEnv { envNotes :: Notes
75+ , envNumbering :: Numbering
76+ , envRelationships :: [Relationship]
77+ , envMedia :: Media
78+ }
79+ deriving Show
74
80
75−attrToNSPair :: Attr -> Maybe (String, String)
81+data DocxError = DocxError | WrongElem
76−attrToNSPair (Attr (QName s _ (Just "xmlns")) val) = Just (s, val)
82+ deriving Show
77−attrToNSPair _ = Nothing
83+
84+instance Error DocxError where
85+ noMsg = WrongElem
86+
87+type D = ErrorT DocxError (Reader ReaderEnv)
88+
89+runD :: D a -> ReaderEnv -> Either DocxError a
90+runD dx re = runReader (runErrorT 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
78
102
79
103
80type NameSpaces = [(String, String)]
104type NameSpaces = [(String, String)]
81
105
82−data Docx = Docx Document Notes Numbering [Relationship] Media
106+data Docx = Docx Document
83 deriving Show
107 deriving Show
84
108
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−
94data Document = Document NameSpaces Body
109data Document = Document NameSpaces Body
95 deriving Show
110 deriving Show
96
111
97−archiveToDocument :: Archive -> Maybe Document
112+data Body = Body [BodyPart]
98−archiveToDocument zf = do
113+ deriving Show
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
105
114
106type Media = [(FilePath, B.ByteString)]
115type Media = [(FilePath, B.ByteString)]
107
116
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−
124data Numbering = Numbering NameSpaces [Numb] [AbstractNumb]
117data Numbering = Numbering NameSpaces [Numb] [AbstractNumb]
125 deriving Show
118 deriving Show
126
119
@@ -133,240 +126,12 @@ data AbstractNumb = AbstractNumb String [Level]
133-- (ilvl, format, string, start)
126-- (ilvl, format, string, start)
134type Level = (String, String, String, Maybe Integer)
127type Level = (String, String, String, Maybe Integer)
135
128
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−
246data Relationship = Relationship (RelId, Target)
129data Relationship = Relationship (RelId, Target)
247 deriving Show
130 deriving Show
248−
131+data Notes = Notes NameSpaces
249−lookupRelationship :: RelId -> [Relationship] -> Maybe Target
132+ (Maybe (M.Map String Element))
250−lookupRelationship relid rels =
133+ (Maybe (M.Map String Element))
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
134+ 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)
370
135
371data ParIndentation = ParIndentation { leftParIndent :: Maybe Integer
136data ParIndentation = ParIndentation { leftParIndent :: Maybe Integer
372 , rightParIndent :: Maybe Integer
137 , rightParIndent :: Maybe Integer
@@ -383,40 +148,9 @@ defaultParagraphStyle = ParagraphStyle { pStyle = []
383 , indentation = Nothing
148 , indentation = Nothing
384 }
149 }
385
150
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−
417
151
418data BodyPart = Paragraph ParagraphStyle [ParPart]
152data BodyPart = Paragraph ParagraphStyle [ParPart]
419− | ListItem ParagraphStyle String String [ParPart]
153+ | ListItem ParagraphStyle String String Level [ParPart]
420 | Tbl String TblGrid TblLook [Row]
154 | Tbl String TblGrid TblLook [Row]
421 | OMathPara OMathParaStyle [OMath]
155 | OMathPara OMathParaStyle [OMath]
422 deriving Show
156 deriving Show
@@ -429,62 +163,22 @@ data TblLook = TblLook {firstRowFormatting::Bool}
429defaultTblLook :: TblLook
163defaultTblLook :: TblLook
430defaultTblLook = TblLook{firstRowFormatting = False}
164defaultTblLook = TblLook{firstRowFormatting = False}
431
165
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−
449data Row = Row [Cell]
166data Row = Row [Cell]
450 deriving Show
167 deriving Show
451
168
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−
463data Cell = Cell [BodyPart]
169data Cell = Cell [BodyPart]
464 deriving Show
170 deriving Show
465
171
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−
473data ParPart = PlainRun Run
172data ParPart = PlainRun Run
474 | Insertion ChangeId Author ChangeDate [Run]
173 | Insertion ChangeId Author ChangeDate [Run]
475 | Deletion ChangeId Author ChangeDate [Run]
174 | Deletion ChangeId Author ChangeDate [Run]
476 | BookMark BookMarkId Anchor
175 | BookMark BookMarkId Anchor
477 | InternalHyperLink Anchor [Run]
176 | InternalHyperLink Anchor [Run]
478− | ExternalHyperLink RelId [Run]
177+ | ExternalHyperLink URL [Run]
479− | Drawing String
178+ | Drawing FilePath B.ByteString
480 | PlainOMath OMath
179 | PlainOMath OMath
481 deriving Show
180 deriving Show
482
181
483−data Run = Run RunStyle [RunElem]
484− | Footnote String
485− | Endnote String
486− deriving Show
487−
488data OMath = OMath [OMathElem]
182data OMath = OMath [OMathElem]
489 deriving Show
183 deriving Show
490
184
@@ -554,6 +248,12 @@ defaultGroupStyle = GroupStyle {groupChr = Nothing, groupPos = Nothing}
554
248
555type OMathRunStyle = [String]
249type OMathRunStyle = [String]
556
250
251+
252+data Run = Run RunStyle [RunElem]
253+ | Footnote [BodyPart]
254+ | Endnote [BodyPart]
255+ deriving Show
256+
557data RunElem = TextRun String | LnBrk | Tab
257data RunElem = TextRun String | LnBrk | Tab
558 deriving Show
258 deriving Show
559
259
@@ -563,7 +263,7 @@ data RunStyle = RunStyle { isBold :: Bool
563 , isStrike :: Bool
263 , isStrike :: Bool
564 , isSuperScript :: Bool
264 , isSuperScript :: Bool
565 , isSubScript :: Bool
265 , isSubScript :: Bool
566− , underline :: Maybe String
266+ , rUnderline :: Maybe String
567 , rStyle :: Maybe String }
267 , rStyle :: Maybe String }
568 deriving Show
268 deriving Show
569
269
@@ -574,104 +274,327 @@ defaultRunStyle = RunStyle { isBold = False
574 , isStrike = False
274 , isStrike = False
575 , isSuperScript = False
275 , isSuperScript = False
576 , isSubScript = False
276 , isSubScript = False
577− , underline = Nothing
277+ , rUnderline = Nothing
578 , rStyle = Nothing
278 , rStyle = Nothing
579 }
279 }
580
280
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
607
281
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+
608−elemToRun :: NameSpaces -> Element -> Maybe Run
410+levelElemToLevel :: NameSpaces -> Element -> Maybe Level
609−elemToRun ns element
411+levelElemToLevel ns element |
610− | qName (elName element) == "r" &&
412+ qName (elName element) == "lvl" &&
611− qURI (elName element) == (lookup "w" ns) =
413+ qURI (elName element) == (lookup "w" ns) = do
612− case
613− findChild (QName "footnoteReference" (lookup "w" ns) (Just "w")) element >>=
414+ ilvl <- findAttr (QName "ilvl" (lookup "w" ns) (Just "w")) element
614− findAttr (QName "id" (lookup "w" ns) (Just "w"))
415+ fmt <- findChild (QName "numFmt" (lookup "w" ns) (Just "w")) element
615− of
616− Just s -> Just $ Footnote s
617− Nothing ->
618− case
619− findChild (QName "endnoteReference" (lookup "w" ns) (Just "w")) element >>=
416+ >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
620− findAttr (QName "id" (lookup "w" ns) (Just "w"))
417+ txt <- findChild (QName "lvlText" (lookup "w" ns) (Just "w")) element
621− of
418+ >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
622− Just s -> Just $ Endnote s
419+ let start = findChild (QName "start" (lookup "w" ns) (Just "w")) element
623− Nothing -> Just $
420+ >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
624− Run (elemToRunStyle ns element)
421+ >>= (\s -> listToMaybe (map fst (reads s :: [(Integer, String)])))
625− (elemToRunElems ns element)
422+ return (ilvl, fmt, txt, start)
626−elemToRun _ _ = Nothing
423+levelElemToLevel _ _ = Nothing
627−
424+
628−elemToRunElem :: NameSpaces -> Element -> Maybe RunElem
425+archiveToNumbering' :: Archive -> Maybe Numbering
629−elemToRunElem ns element
426+archiveToNumbering' zf = do
630− | (qName (elName element) == "t" || qName (elName element) == "delText") &&
427+ case findEntryByPath "word/numbering.xml" zf of
631− qURI (elName element) `elem` [(lookup "w" ns), (lookup "m" ns)] =
428+ Nothing -> Just $ Numbering [] [] []
632− Just $ TextRun (strContent element)
429+ Just entry -> do
633− | qName (elName element) == "br" &&
430+ numberingElem <- (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry
634− qURI (elName element) `elem` [(lookup "w" ns), (lookup "m" ns)] =
431+ let namespaces = mapMaybe attrToNSPair (elAttribs numberingElem)
635− Just $ LnBrk
432+ numElems = findChildren
636− | qName (elName element) == "tab" &&
433+ (QName "num" (lookup "w" namespaces) (Just "w"))
637− qURI (elName element) `elem` [(lookup "w" ns), (lookup "m" ns)] =
434+ numberingElem
638− Just $ Tab
435+ absNumElems = findChildren
639− | otherwise = Nothing
436+ (QName "abstractNum" (lookup "w" namespaces) (Just "w"))
640−
437+ numberingElem
641−
438+ nums = mapMaybe (numElemToNum namespaces) numElems
642−elemToRunElems :: NameSpaces -> Element -> [RunElem]
439+ absNums = mapMaybe (absNumElemToAbsNum namespaces) absNumElems
643−elemToRunElems ns element
440+ return $ Numbering namespaces nums absNums
644− | qName (elName element) == "r" &&
441+
645− qURI (elName element) `elem` [(lookup "w" ns), (lookup "m" ns)] =
442+archiveToNumbering :: Archive -> Numbering
646− mapMaybe (elemToRunElem ns) (elChildren element)
443+archiveToNumbering archive =
647− | otherwise = []
444+ fromMaybe (Numbering [] [] []) (archiveToNumbering' archive)
648−
445+
649−elemToDrawing :: NameSpaces -> Element -> Maybe ParPart
446+elemToNotes :: NameSpaces -> String -> Element -> Maybe (M.Map String Element)
650−elemToDrawing ns element
447+elemToNotes ns notetype element
651− | qName (elName element) == "drawing" &&
448+ | isElem ns "w" (notetype ++ "s") element =
652− qURI (elName element) == (lookup "w" ns) =
449+ let pairs = mapMaybe
653− let a_ns = "http://schemas.openxmlformats.org/drawingml/2006/main"
450+ (\e -> findAttr (elemName ns "w" "id") e >>=
451+ (\a -> Just (a, e)))
452+ (findChildren (elemName ns "w" notetype) element)
654 in
453 in
655− findElement (QName "blip" (Just a_ns) (Just "a")) element
454+ Just $ M.fromList $ pairs
656− >>= findAttr (QName "embed" (lookup "r" ns) (Just "r"))
657− >>= (\s -> Just $ Drawing s)
658−elemToDrawing _ _ = Nothing
455+elemToNotes _ _ _ = Nothing
659
456
660−elemToMath :: NameSpaces -> Element -> Maybe OMath
457+---------------------------------------------
661−elemToMath ns element
458+---------------------------------------------
662− | qName (elName element) == "oMath" &&
663− qURI (elName element) == (lookup "m" ns) =
664− Just $ OMath $ mapMaybe (elemToMathElem ns) (elChildren element)
665−elemToMath _ _ = Nothing
666
459
460+elemName :: NameSpaces -> String -> String -> QName
461+elemName ns prefix name = (QName name (lookup prefix ns) (Just prefix))
667
462
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)
668
467
669−elemToBase :: NameSpaces -> Element -> Maybe Base
468+
670−elemToBase ns element
469+elemToTblGrid :: NameSpaces -> Element -> D TblGrid
671− | qName (elName element) == "e" &&
470+elemToTblGrid ns element | isElem ns "w" "tblGrid" element =
672− qURI (elName element) == (lookup "m" ns) =
471+ let cols = findChildren (elemName ns "w" "gridCol") element
673− Just $ Base $ mapMaybe (elemToMathElem ns) (elChildren element)
472+ in
674−elemToBase _ _ = Nothing
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
675
598
676elemToNAryStyle :: NameSpaces -> Element -> NAryStyle
599elemToNAryStyle :: NameSpaces -> Element -> NAryStyle
677elemToNAryStyle ns element
600elemToNAryStyle ns element
@@ -721,225 +644,287 @@ elemToGroupStyle ns element
721 GroupStyle { groupChr = chr, groupPos = pos }
644 GroupStyle { groupChr = chr, groupPos = pos }
722elemToGroupStyle _ _ = defaultGroupStyle
645elemToGroupStyle _ _ = defaultGroupStyle
723
646
724−elemToMathElem :: NameSpaces -> Element -> Maybe OMathElem
647+elemToMathElem :: NameSpaces -> Element -> D OMathElem
725−elemToMathElem ns element
648+elemToMathElem ns element | isElem ns "m" "acc" element = do
726− | qName (elName element) == "acc" &&
649+ let accChar =
727− qURI (elName element) == (lookup "m" ns) = do
650+ findChild (QName "accPr" (lookup "m" ns) (Just "m")) element >>=
728− let accChar =
651+ findChild (QName "chr" (lookup "m" ns) (Just "m")) >>=
729− findChild (QName "accPr" (lookup "m" ns) (Just "m")) element >>=
652+ findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
730− findChild (QName "chr" (lookup "m" ns) (Just "m")) >>=
653+ Just . head
731− findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
654+ accPr = AccentStyle { accentChar = accChar}
732− Just . head
655+ base <-(maybeToD $ findChild (elemName ns "m" "e") element) >>=
733− accPr = AccentStyle { accentChar = accChar}
656+ elemToBase ns
734− base <-findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
657+ return $ Accent accPr base
735− elemToBase ns
658+elemToMathElem ns element | isElem ns "m" "bar" element = do
736− return $ Accent accPr base
659+ barPr <- maybeToD $
737−elemToMathElem ns element
660+ findChild (QName "barPr" (lookup "m" ns) (Just "m")) element >>=
738− | qName (elName element) == "bar" &&
661+ findChild (QName "pos" (lookup "m" ns) (Just "m")) >>=
739− qURI (elName element) == (lookup "m" ns) = do
662+ findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
740− barPr <- findChild (QName "barPr" (lookup "m" ns) (Just "m")) element >>=
663+ (\s ->
741− findChild (QName "pos" (lookup "m" ns) (Just "m")) >>=
664+ Just $ BarStyle {
742− findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
665+ barPos = (if s == "bot" then Bottom else Top)
743− (\s ->
666+ })
744− Just $ BarStyle {
667+ base <-maybeToD (findChild (QName "e" (lookup "m" ns) (Just "m")) element) >>=
745− barPos = (if s == "bot" then Bottom else Top)
668+ elemToBase ns
746− })
669+ return $ Bar barPr base
747− base <-findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
670+elemToMathElem ns element | isElem ns "m" "box" element =
748− elemToBase ns
671+ maybeToD (findChild (elemName ns "m" "e") element) >>=
749− return $ Bar barPr base
672+ elemToBase ns >>=
750−elemToMathElem ns element
673+ (\b -> return $ Box b)
751− | qName (elName element) == "box" &&
674+elemToMathElem ns element | isElem ns "m" "borderBox" element =
752− qURI (elName element) == (lookup "m" ns) =
675+ maybeToD (findChild (elemName ns "m" "e") element) >>=
753− findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
676+ elemToBase ns >>=
754− elemToBase ns >>=
677+ (\b -> return $ BorderBox b)
755− (\b -> Just $ Box b)
678+elemToMathElem ns element | isElem ns "m" "d" element =
756−elemToMathElem ns element
679+ let style = elemToDelimStyle ns element
757− | qName (elName element) == "borderBox" &&
680+ in
758− qURI (elName element) == (lookup "m" ns) =
681+ mapD (elemToBase ns) (elChildren element) >>=
759− findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
682+ (\es -> return $ Delimiter style es)
760− elemToBase ns >>=
683+elemToMathElem ns element | isElem ns "m" "eqArr" element =
761− (\b -> Just $ BorderBox b)
684+ mapD (elemToBase ns) (elChildren element) >>=
762−elemToMathElem ns element
685+ (\es -> return $ EquationArray es)
763− | qName (elName element) == "d" &&
686+elemToMathElem ns element | isElem ns "m" "f" element = do
764− qURI (elName element) == (lookup "m" ns) =
687+ num <- maybeToD $ findChild (elemName ns "m" "num") element
765− let style = elemToDelimStyle ns element
688+ den <- maybeToD $ findChild (elemName ns "m" "den") element
766− in
689+ numElems <- mapD (elemToMathElem ns) (elChildren num)
767− Just $ Delimiter style $ mapMaybe (elemToBase ns) (elChildren element)
690+ denElems <- mapD (elemToMathElem ns) (elChildren den)
768−elemToMathElem ns element
691+ return $ Fraction numElems denElems
769− | qName (elName element) == "eqArr" &&
692+elemToMathElem ns element | isElem ns "m" "func" element = do
770− qURI (elName element) == (lookup "m" ns) =
693+ fName <- maybeToD $ findChild (elemName ns "m" "fName") element
771− Just $ EquationArray
694+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
772− $ mapMaybe (elemToBase ns) (elChildren element)
695+ elemToBase ns
773−elemToMathElem ns element
696+ fnElems <- mapD (elemToMathElem ns) (elChildren fName)
774− | qName (elName element) == "f" &&
697+ return $ Function fnElems base
775− qURI (elName element) == (lookup "m" ns) = do
698+elemToMathElem ns element | isElem ns "m" "groupChr" element =
776− num <- findChild (QName "num" (lookup "m" ns) (Just "m")) element
699+ let style = elemToGroupStyle ns element
777− den <- findChild (QName "den" (lookup "m" ns) (Just "m")) element
700+ in
778− let numElems = mapMaybe (elemToMathElem ns) (elChildren num)
701+ maybeToD (findChild (elemName ns "m" "e") element) >>=
779− denElems = mapMaybe (elemToMathElem ns) (elChildren den)
702+ elemToBase ns >>=
780− return $ Fraction numElems denElems
703+ (\b -> return $ Group style b)
781−elemToMathElem ns element
704+elemToMathElem ns element | isElem ns "m" "limLow" element = do
782− | qName (elName element) == "func" &&
705+ base <- maybeToD (findChild (elemName ns "m" "e") element)
783− qURI (elName element) == (lookup "m" ns) = do
706+ >>= elemToBase ns
784− fName <- findChild (QName "fName" (lookup "m" ns) (Just "m")) element
707+ lim <- maybeToD $ findChild (elemName ns "m" "lim") element
785− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
708+ limElems <- mapD (elemToMathElem ns) (elChildren lim)
786− elemToBase ns
709+ return $ LowerLimit base limElems
787− let fnElems = mapMaybe (elemToMathElem ns) (elChildren fName)
710+elemToMathElem ns element | isElem ns "m" "limUpp" element = do
788− return $ Function fnElems base
711+ base <- maybeToD (findChild (elemName ns "m" "e") element)
789−elemToMathElem ns element
712+ >>= elemToBase ns
790− | qName (elName element) == "groupChr" &&
713+ lim <- maybeToD $ findChild (elemName ns "m" "lim") element
791− qURI (elName element) == (lookup "m" ns) =
714+ limElems <- mapD (elemToMathElem ns) (elChildren lim)
792− let style = elemToGroupStyle ns element
715+ return $ UpperLimit base limElems
793− in
716+elemToMathElem ns element | isElem ns "m" "m" element = do
794− findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
717+ let rows = findChildren (elemName ns "m" "mr") element
795− elemToBase ns >>=
718+ bases <- mapD (\mr -> mapD (elemToBase ns) (elChildren mr)) rows
796− (\b -> Just $ Group style b)
719+ return $ Matrix bases
797−elemToMathElem ns element
720+elemToMathElem ns element | isElem ns "m" "nary" element = do
798− | qName (elName element) == "limLow" &&
721+ let style = elemToNAryStyle ns element
799− qURI (elName element) == (lookup "m" ns) = do
722+ sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>=
800− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element
723+ (\e -> mapD (elemToMathElem ns) (elChildren e))
801− >>= elemToBase ns
724+ sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>=
802− lim <- findChild (QName "lim" (lookup "m" ns) (Just "m")) element
725+ (\e -> mapD (elemToMathElem ns) (elChildren e))
803− return $ LowerLimit base (mapMaybe (elemToMathElem ns) (elChildren lim))
726+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
804−elemToMathElem ns element
727+ elemToBase ns
805− | qName (elName element) == "limUpp" &&
728+ return $ NAry style sub sup base
806− qURI (elName element) == (lookup "m" ns) = do
729+elemToMathElem ns element | isElem ns "m" "rad" element = do
807− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element
730+ deg <- maybeToD (findChild (elemName ns "m" "deg") element) >>=
808− >>= elemToBase ns
731+ (\e -> mapD (elemToMathElem ns) (elChildren e))
809− lim <- findChild (QName "lim" (lookup "m" ns) (Just "m")) element
732+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
810− return $ UpperLimit base (mapMaybe (elemToMathElem ns) (elChildren lim))
733+ elemToBase ns
811−elemToMathElem ns element
734+ return $ Radical deg base
812− | qName (elName element) == "m" &&
735+elemToMathElem ns element | isElem ns "m" "phant" element = do
813− qURI (elName element) == (lookup "m" ns) =
736+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
814− let rows = findChildren (QName "mr" (lookup "m" ns) (Just "m")) element
737+ elemToBase ns
815− bases = map (\mr -> mapMaybe (elemToBase ns) (elChildren mr)) rows
738+ return $ Phantom base
816− in
739+elemToMathElem ns element | isElem ns "m" "sPre" element = do
817− Just $ Matrix bases
740+ sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>=
818−elemToMathElem ns element
741+ (\e -> mapD (elemToMathElem ns) (elChildren e))
819− | qName (elName element) == "nary" &&
742+ sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>=
820− qURI (elName element) == (lookup "m" ns) = do
743+ (\e -> mapD (elemToMathElem ns) (elChildren e))
821− let style = elemToNAryStyle ns element
744+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
822− sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=
745+ elemToBase ns
823− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
746+ return $ PreSubSuper sub sup base
824− sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=
747+elemToMathElem ns element | isElem ns "m" "sSub" element = do
825− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
748+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
826− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
749+ elemToBase ns
827− elemToBase ns
750+ sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>=
828− return $ NAry style sub sup base
751+ (\e -> mapD (elemToMathElem ns) (elChildren e))
829−elemToMathElem ns element
752+ return $ Sub base sub
830− | qName (elName element) == "rad" &&
753+elemToMathElem ns element | isElem ns "m" "sSubSup" element = do
831− qURI (elName element) == (lookup "m" ns) = do
754+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
832− deg <- findChild (QName "deg" (lookup "m" ns) (Just "m")) element >>=
755+ elemToBase ns
833− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
756+ sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>=
834− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
757+ (\e -> mapD (elemToMathElem ns) (elChildren e))
835− elemToBase ns
758+ sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>=
836− return $ Radical deg base
759+ (\e -> mapD (elemToMathElem ns) (elChildren e))
837−-- skipping for now:
760+ return $ SubSuper base sub sup
838−-- phant
761+elemToMathElem ns element | isElem ns "m" "sSup" element = do
839−elemToMathElem ns element
762+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
840− | qName (elName element) == "sPre" &&
763+ elemToBase ns
841− qURI (elName element) == (lookup "m" ns) = do
764+ sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>=
842− sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=
765+ (\e -> mapD (elemToMathElem ns) (elChildren e))
843− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
766+ return $ Sub base sup
844− sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=
767+elemToMathElem ns element | isElem ns "m" "r" element = do
845− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
768+ let style = [] -- placeholder
846− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
769+ rstyle = elemToRunStyle ns element
847− elemToBase ns
770+ relems <- elemToRunElems ns element
848− return $ PreSubSuper sub sup base
771+ return $ OMathRun style $ Run rstyle relems
849−elemToMathElem ns element
772+elemToMathElem _ _ = throwError WrongElem
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
884
773
774+lookupRelationship :: RelId -> [Relationship] -> Maybe Target
775+lookupRelationship relid rels =
776+ lookup relid (map (\(Relationship pair) -> pair) rels)
885
777
886−
778+expandDrawingId :: String -> D ParPart
887−elemToParPart :: NameSpaces -> Element -> Maybe 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
888elemToParPart ns element
790elemToParPart ns element
889− | qName (elName element) == "r" &&
791+ | isElem ns "w" "r" element
890− qURI (elName element) == (lookup "w" ns) =
792+ , Just _ <- findChild (elemName ns "w" "drawing") element =
891− case findChild (QName "drawing" (lookup "w" ns) (Just "w")) element of
793+ let a_ns = "http://schemas.openxmlformats.org/drawingml/2006/main"
892− Just drawingElem -> elemToDrawing ns drawingElem
794+ drawing = findElement (QName "blip" (Just a_ns) (Just "a")) element
893− Nothing -> do
795+ >>= findAttr (QName "embed" (lookup "r" ns) (Just "r"))
894− r <- elemToRun ns element
796+ in
895− return $ PlainRun r
797+ case drawing of
798+ Just s -> expandDrawingId s
799+ Nothing -> throwError WrongElem
896elemToParPart ns element
800elemToParPart ns element
897− | qName (elName element) == "ins" &&
801+ | isElem ns "w" "r" element =
898− qURI (elName element) == (lookup "w" ns) = do
802+ elemToRun ns element >>= (\r -> return $ PlainRun r)
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
904elemToParPart ns element
803elemToParPart ns element
905− | qName (elName element) == "del" &&
804+ | isElem ns "w" "ins" element
906− qURI (elName element) == (lookup "w" ns) = do
805+ , Just cId <- findAttr (elemName ns "w" "id") element
907− cId <- findAttr (QName "id" (lookup "w" ns) (Just "w")) element
806+ , Just cAuthor <- findAttr (elemName ns "w" "author") element
908− cAuthor <- findAttr (QName "author" (lookup "w" ns) (Just "w")) element
807+ , Just cDate <- findAttr (elemName ns "w" "date") element = do
909− cDate <- findAttr (QName "date" (lookup "w" ns) (Just "w")) element
808+ runs <- mapD (elemToRun ns) (elChildren element)
910− let runs = mapMaybe (elemToRun ns) (elChildren element)
809+ return $ Insertion cId cAuthor cDate runs
911− return $ Deletion cId cAuthor cDate runs
912elemToParPart ns element
810elemToParPart ns element
913− | qName (elName element) == "bookmarkStart" &&
811+ | isElem ns "w" "del" element
914− qURI (elName element) == (lookup "w" ns) = do
812+ , Just cId <- findAttr (elemName ns "w" "id") element
915− bmId <- findAttr (QName "id" (lookup "w" ns) (Just "w")) element
813+ , Just cAuthor <- findAttr (elemName ns "w" "author") element
916− bmName <- findAttr (QName "name" (lookup "w" ns) (Just "w")) element
814+ , Just cDate <- findAttr (elemName ns "w" "date") element = do
917− return $ BookMark bmId bmName
815+ runs <- mapD (elemToRun ns) (elChildren element)
816+ return $ Deletion cId cAuthor cDate runs
918elemToParPart ns element
817elemToParPart ns element
919− | qName (elName element) == "hyperlink" &&
818+ | isElem ns "w" "bookmarkStart" element
920− qURI (elName element) == (lookup "w" ns) =
819+ , Just bmId <- findAttr (elemName ns "w" "id") element
921− let runs = mapMaybe (elemToRun ns)
820+ , Just bmName <- findAttr (elemName ns "w" "name") element =
922− $ findChildren (QName "r" (lookup "w" ns) (Just "w")) element
821+ return $ BookMark bmId bmName
923− in
822+elemToParPart ns element
924− case findAttr (QName "anchor" (lookup "w" ns) (Just "w")) element of
823+ | isElem ns "w" "hyperlink" element
925− Just anchor ->
824+ , Just anchor <- findAttr (elemName ns "w" "anchor") element = do
926− Just $ InternalHyperLink anchor runs
825+ runs <- mapD (elemToRun ns) (elChildren element)
927− Nothing ->
826+ return $ InternalHyperLink anchor runs
928− case findAttr (QName "id" (lookup "r" ns) (Just "r")) element of
929− Just relId -> Just $ ExternalHyperLink relId runs
930− Nothing -> Nothing
931elemToParPart ns element
827elemToParPart ns element
932− | qName (elName element) == "oMath" &&
828+ | isElem ns "w" "hyperlink" element
933− qURI (elName element) == (lookup "m" ns) =
829+ , Just relId <- findAttr (elemName ns "r" "id") element = do
934− elemToMath ns element >>=
830+ runs <- mapD (elemToRun ns) (elChildren element)
935− (\m -> Just $ PlainOMath m)
831+ rels <- asks envRelationships
936−elemToParPart _ _ = Nothing
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
937
881
938
882
939−type Target = String
883+elemToRunStyle :: NameSpaces -> Element -> RunStyle
940−type Anchor = String
884+elemToRunStyle ns element
941−type BookMarkId = String
885+ | Just rPr <- findChild (elemName ns "w" "rPr") element =
942−type RelId = String
886+ RunStyle
943−type ChangeId = String
887+ {
944−type Author = String
888+ isBold = isJust $ findChild (QName "b" (lookup "w" ns) (Just "w")) rPr
945−type ChangeDate = String
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+