git.iko.soy/typeable/pandoc
on master help sign in
Add DocX files to tree.

This introduces Text.Pandoc.DocX, and its exported `readDocX` function.

commit293e4cfdc3028218089115acd6f091b9ea3aa7d6 authorJesse Rosenthal <jrosenthal@jhu.edu> dateSat 14 Jun 2014, 10:02 (12 years ago) parentabbf33a
3 files changed+1291
compare with master
unifiedsplit
src/Text/Pandoc/Readers/DocX.hs+479 src/Text/Pandoc/Readers/DocX/Lists.hs+208 src/Text/Pandoc/Readers/DocX/Parse.hs+604
src/Text/Pandoc/Readers/DocX.hsnew file+479
@@ -0,0 +1,479 @@
1+{-
2+Copyright (C) 2014 Jesse Rosenthal <jrosenthal@jhu.edu>
3+
4+This program is free software; you can redistribute it and/or modify
5+it under the terms of the GNU General Public License as published by
6+the Free Software Foundation; either version 2 of the License, or
7+(at your option) any later version.
8+
9+This program is distributed in the hope that it will be useful,
10+but WITHOUT ANY WARRANTY; without even the implied warranty of
11+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12+GNU General Public License for more details.
13+
14+You should have received a copy of the GNU General Public License
15+along with this program; if not, write to the Free Software
16+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17+-}
18+
19+{- |
20+ Module : Text.Pandoc.Readers.DocX
21+ Copyright : Copyright (C) 2014 Jesse Rosenthal
22+ License : GNU GPL, version 2 or above
23+
24+ Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
25+ Stability : alpha
26+ Portability : portable
27+
28+Conversion of DocX type (defined in Text.Pandoc.Readers.DocX.Parse)
29+to 'Pandoc' document. -}
30+
31+{-
32+Current state of implementation of DocX entities ([x] means
33+implemented, [-] means partially implemented):
34+
35+* Blocks
36+
37+ - [X] Para
38+ - [X] CodeBlock (styled with `SourceCode`)
39+ - [X] BlockQuote (styled with `Quote`, `BlockQuote`, or, optionally,
40+ indented)
41+ - [X] OrderedList
42+ - [X] BulletList
43+ - [X] DefinitionList (styled with adjacent `DefinitionTerm` and `Definition`)
44+ - [X] Header (styled with `Heading#`)
45+ - [ ] HorizontalRule
46+ - [-] Table (column widths and alignments not yet implemented)
47+
48+* Inlines
49+
50+ - [X] Str
51+ - [X] Emph (From italics. `underline` currently read as span. In
52+ future, it might optionally be emph as well)
53+ - [X] Strong
54+ - [X] Strikeout
55+ - [X] Superscript
56+ - [X] Subscript
57+ - [X] SmallCaps
58+ - [ ] Quoted
59+ - [ ] Cite
60+ - [X] Code (styled with `VerbatimChar`)
61+ - [X] Space
62+ - [X] LineBreak (these are invisible in Word: entered with Shift-Return)
63+ - [ ] Math
64+ - [X] Link (links to an arbitrary bookmark create a span with the target as
65+ id and "anchor" class)
66+ - [-] Image (Links to path in archive. Future option for
67+ data-encoded URI likely.)
68+ - [X] Note (Footnotes and Endnotes are silently combined.)
69+-}
70+
71+module Text.Pandoc.Readers.DocX
72+ ( readDocX
73+ ) where
74+
75+import Codec.Archive.Zip
76+import Text.Pandoc.Definition
77+import Text.Pandoc.Options
78+import Text.Pandoc.Builder (text, toList)
79+import Text.Pandoc.Generic (bottomUp)
80+import Text.Pandoc.MIME (getMimeType)
81+import Text.Pandoc.UTF8 (toString)
82+import Text.Pandoc.Readers.DocX.Parse
83+import Text.Pandoc.Readers.DocX.Lists
84+import Data.Maybe (mapMaybe, isJust, fromJust)
85+import Data.List (delete, isPrefixOf, (\\), intersect)
86+import qualified Data.ByteString as BS
87+import qualified Data.ByteString.Lazy as B
88+import Data.ByteString.Base64 (encode)
89+import System.FilePath (combine)
90+
91+readDocX :: ReaderOptions
92+ -> B.ByteString
93+ -> Pandoc
94+readDocX opts bytes =
95+ case archiveToDocX (toArchive bytes) of
96+ Just docx -> Pandoc nullMeta (docxToBlocks opts docx)
97+ Nothing -> error $ "couldn't parse docx file"
98+
99+runStyleToSpanAttr :: RunStyle -> (String, [String], [(String, String)])
100+runStyleToSpanAttr rPr = ("",
101+ mapMaybe id [
102+ if isBold rPr then (Just "strong") else Nothing,
103+ if isItalic rPr then (Just "emph") else Nothing,
104+ if isSmallCaps rPr then (Just "smallcaps") else Nothing,
105+ if isStrike rPr then (Just "strike") else Nothing,
106+ if isSuperScript rPr then (Just "superscript") else Nothing,
107+ if isSubScript rPr then (Just "subscript") else Nothing,
108+ rStyle rPr],
109+ case underline rPr of
110+ Just fmt -> [("underline", fmt)]
111+ _ -> []
112+ )
113+
114+parStyleToDivAttr :: ParagraphStyle -> (String, [String], [(String, String)])
115+parStyleToDivAttr pPr = ("",
116+ pStyle pPr,
117+ case indent pPr of
118+ Just n -> [("indent", (show n))]
119+ Nothing -> []
120+ )
121+
122+strToInlines :: String -> [Inline]
123+strToInlines = toList . text
124+
125+codeSpans :: [String]
126+codeSpans = ["VerbatimChar"]
127+
128+blockQuoteDivs :: [String]
129+blockQuoteDivs = ["Quote", "BlockQuote"]
130+
131+codeDivs :: [String]
132+codeDivs = ["SourceCode"]
133+
134+runElemToInlines :: RunElem -> [Inline]
135+runElemToInlines (TextRun s) = strToInlines s
136+runElemToInlines (LnBrk) = [LineBreak]
137+
138+runElemToString :: RunElem -> String
139+runElemToString (TextRun s) = s
140+runElemToString (LnBrk) = ['\n']
141+
142+runElemsToString :: [RunElem] -> String
143+runElemsToString = concatMap runElemToString
144+
145+strNormalize :: [Inline] -> [Inline]
146+strNormalize [] = []
147+strNormalize (Str "" : ils) = strNormalize ils
148+strNormalize ((Str s) : (Str s') : l) = strNormalize ((Str (s++s')) : l)
149+strNormalize (il:ils) = il : (strNormalize ils)
150+
151+runToInlines :: ReaderOptions -> DocX -> Run -> [Inline]
152+runToInlines _ _ (Run rs runElems)
153+ | isJust (rStyle rs) && (fromJust (rStyle rs)) `elem` codeSpans =
154+ case runStyleToSpanAttr rs == ("", [], []) of
155+ True -> [Str (runElemsToString runElems)]
156+ False -> [Span (runStyleToSpanAttr rs) [Str (runElemsToString runElems)]]
157+ | otherwise = case runStyleToSpanAttr rs == ("", [], []) of
158+ True -> concatMap runElemToInlines runElems
159+ False -> [Span (runStyleToSpanAttr rs) (concatMap runElemToInlines runElems)]
160+runToInlines opts docx@(DocX _ notes _ _ _ ) (Footnote fnId) =
161+ case (getFootNote fnId notes) of
162+ Just bodyParts ->
163+ [Note [Div ("", ["footnote"], []) (map (bodyPartToBlock opts docx) bodyParts)]]
164+ Nothing ->
165+ [Note [Div ("", ["footnote"], []) []]]
166+runToInlines opts docx@(DocX _ notes _ _ _) (Endnote fnId) =
167+ case (getEndNote fnId notes) of
168+ Just bodyParts ->
169+ [Note [Div ("", ["endnote"], []) (map (bodyPartToBlock opts docx) bodyParts)]]
170+ Nothing ->
171+ [Note [Div ("", ["endnote"], []) []]]
172+
173+parPartToInlines :: ReaderOptions -> DocX -> ParPart -> [Inline]
174+parPartToInlines opts docx (PlainRun r) = runToInlines opts docx r
175+parPartToInlines _ _ (BookMark _ anchor) =
176+ [Span (anchor, ["anchor"], []) []]
177+parPartToInlines _ (DocX _ _ _ rels _) (Drawing relid) =
178+ case lookupRelationship relid rels of
179+ Just target -> [Image [] (combine "word" target, "")]
180+ Nothing -> [Image [] ("", "")]
181+parPartToInlines opts docx (InternalHyperLink anchor runs) =
182+ [Link (concatMap (runToInlines opts docx) runs) ('#' : anchor, "")]
183+parPartToInlines opts docx@(DocX _ _ _ rels _) (ExternalHyperLink relid runs) =
184+ case lookupRelationship relid rels of
185+ Just target ->
186+ [Link (concatMap (runToInlines opts docx) runs) (target, "")]
187+ Nothing ->
188+ [Link (concatMap (runToInlines opts docx) runs) ("", "")]
189+
190+isAnchorSpan :: Inline -> Bool
191+isAnchorSpan (Span (ident, classes, kvs) ils) =
192+ (not . null) ident &&
193+ classes == ["anchor"] &&
194+ null kvs &&
195+ null ils
196+isAnchorSpan _ = False
197+
198+dummyAnchors :: [String]
199+dummyAnchors = ["_GoBack"]
200+
201+makeHeaderAnchors :: Block -> Block
202+makeHeaderAnchors h@(Header n (_, classes, kvs) ils) =
203+ case filter isAnchorSpan ils of
204+ [] -> h
205+ (x@(Span (ident, _, _) _) : xs) ->
206+ case ident `elem` dummyAnchors of
207+ True -> h
208+ False -> Header n (ident, classes, kvs) (ils \\ (x:xs))
209+ _ -> h
210+makeHeaderAnchors blk = blk
211+
212+
213+parPartsToInlines :: ReaderOptions -> DocX -> [ParPart] -> [Inline]
214+parPartsToInlines opts docx parparts =
215+ --
216+ -- We're going to skip data-uri's for now. It should be an option,
217+ -- not mandatory.
218+ --
219+ --bottomUp (makeImagesSelfContained docx) $
220+ bottomUp spanCorrect $
221+ bottomUp spanTrim $
222+ bottomUp spanReduce $
223+ concatMap (parPartToInlines opts docx) parparts
224+
225+cellToBlocks :: ReaderOptions -> DocX -> Cell -> [Block]
226+cellToBlocks opts docx (Cell bps) = map (bodyPartToBlock opts docx) bps
227+
228+rowToBlocksList :: ReaderOptions -> DocX -> Row -> [[Block]]
229+rowToBlocksList opts docx (Row cells) = map (cellToBlocks opts docx) cells
230+
231+bodyPartToBlock :: ReaderOptions -> DocX -> BodyPart -> Block
232+bodyPartToBlock opts docx (Paragraph pPr parparts) =
233+ Div (parStyleToDivAttr pPr) [Para (parPartsToInlines opts docx parparts)]
234+bodyPartToBlock opts docx@(DocX _ _ numbering _ _) (ListItem pPr numId lvl parparts) =
235+ let
236+ kvs = case lookupLevel numId lvl numbering of
237+ Just (_, fmt, txt, Just start) -> [ ("level", lvl)
238+ , ("num-id", numId)
239+ , ("format", fmt)
240+ , ("text", txt)
241+ , ("start", (show start))
242+ ]
243+
244+ Just (_, fmt, txt, Nothing) -> [ ("level", lvl)
245+ , ("num-id", numId)
246+ , ("format", fmt)
247+ , ("text", txt)
248+ ]
249+ Nothing -> []
250+ in
251+ Div
252+ ("", ["list-item"], kvs)
253+ [bodyPartToBlock opts docx (Paragraph pPr parparts)]
254+bodyPartToBlock _ _ (Tbl _ _ _ []) =
255+ Para []
256+bodyPartToBlock opts docx (Tbl cap _ look (r:rs)) =
257+ let caption = strToInlines cap
258+ (hdr, rows) = case firstRowFormatting look of
259+ True -> (Just r, rs)
260+ False -> (Nothing, r:rs)
261+ hdrCells = case hdr of
262+ Just r' -> rowToBlocksList opts docx r'
263+ Nothing -> []
264+ cells = map (rowToBlocksList opts docx) rows
265+
266+ size = case null hdrCells of
267+ True -> length $ head cells
268+ False -> length $ hdrCells
269+ --
270+ -- The two following variables (horizontal column alignment and
271+ -- relative column widths) go to the default at the
272+ -- moment. Width information is in the TblGrid field of the Tbl,
273+ -- so should be possible. Alignment might be more difficult,
274+ -- since there doesn't seem to be a column entity in docx.
275+ alignments = take size (repeat AlignDefault)
276+ widths = take size (repeat 0) :: [Double]
277+ in
278+ Table caption alignments widths hdrCells cells
279+
280+makeImagesSelfContained :: DocX -> Inline -> Inline
281+makeImagesSelfContained (DocX _ _ _ _ media) i@(Image alt (uri, title)) =
282+ case lookup uri media of
283+ Just bs -> case getMimeType uri of
284+ Just mime -> let data_uri =
285+ "data:" ++ mime ++ ";base64," ++ toString (encode $ BS.concat $ B.toChunks bs)
286+ in
287+ Image alt (data_uri, title)
288+ Nothing -> i
289+ Nothing -> i
290+makeImagesSelfContained _ inline = inline
291+
292+bodyToBlocks :: ReaderOptions -> DocX -> Body -> [Block]
293+bodyToBlocks opts docx (Body bps) =
294+ bottomUp removeEmptyPars $
295+ bottomUp strNormalize $
296+ bottomUp spanRemove $
297+ bottomUp divRemove $
298+ map (makeHeaderAnchors) $
299+ bottomUp divCorrect $
300+ bottomUp divReduce $
301+ bottomUp divCorrectPreReduce $
302+ bottomUp blocksToDefinitions $
303+ blocksToBullets $
304+ map (bodyPartToBlock opts docx) bps
305+
306+docxToBlocks :: ReaderOptions -> DocX -> [Block]
307+docxToBlocks opts d@(DocX (Document _ body) _ _ _ _) = bodyToBlocks opts d body
308+
309+spanReduce :: [Inline] -> [Inline]
310+spanReduce [] = []
311+spanReduce ((Span (id1, classes1, kvs1) ils1) : ils)
312+ | (id1, classes1, kvs1) == ("", [], []) = ils1 ++ (spanReduce ils)
313+spanReduce (s1@(Span (id1, classes1, kvs1) ils1) :
314+ s2@(Span (id2, classes2, kvs2) ils2) :
315+ ils) =
316+ let classes' = classes1 `intersect` classes2
317+ kvs' = kvs1 `intersect` kvs2
318+ classes1' = classes1 \\ classes'
319+ kvs1' = kvs1 \\ kvs'
320+ classes2' = classes2 \\ classes'
321+ kvs2' = kvs2 \\ kvs'
322+ in
323+ case null classes' && null kvs' of
324+ True -> s1 : (spanReduce (s2 : ils))
325+ False -> let attr' = ("", classes', kvs')
326+ attr1' = (id1, classes1', kvs1')
327+ attr2' = (id2, classes2', kvs2')
328+ in
329+ spanReduce (Span attr' [(Span attr1' ils1), (Span attr2' ils2)] :
330+ ils)
331+spanReduce (il:ils) = il : (spanReduce ils)
332+
333+ilToCode :: Inline -> String
334+ilToCode (Str s) = s
335+ilToCode _ = ""
336+
337+spanRemove' :: Inline -> [Inline]
338+spanRemove' s@(Span (ident, classes, _) [])
339+ -- "_GoBack" is automatically inserted. We don't want to keep it.
340+ | classes == ["anchor"] && not (ident `elem` dummyAnchors) = [s]
341+spanRemove' (Span (_, _, kvs) ils) =
342+ case lookup "underline" kvs of
343+ Just val -> [Span ("", [], [("underline", val)]) ils]
344+ Nothing -> ils
345+spanRemove' il = [il]
346+
347+spanRemove :: [Inline] -> [Inline]
348+spanRemove = concatMap spanRemove'
349+
350+spanTrim' :: Inline -> [Inline]
351+spanTrim' il@(Span _ []) = [il]
352+spanTrim' il@(Span attr (il':[]))
353+ | il' == Space = [Span attr [], Space]
354+ | otherwise = [il]
355+spanTrim' (Span attr ils)
356+ | head ils == Space && last ils == Space =
357+ [Space, Span attr (init $ tail ils), Space]
358+ | head ils == Space = [Space, Span attr (tail ils)]
359+ | last ils == Space = [Span attr (init ils), Space]
360+spanTrim' il = [il]
361+
362+spanTrim :: [Inline] -> [Inline]
363+spanTrim = concatMap spanTrim'
364+
365+spanCorrect' :: Inline -> [Inline]
366+spanCorrect' (Span ("", [], []) ils) = ils
367+spanCorrect' (Span (ident, classes, kvs) ils)
368+ | "emph" `elem` classes =
369+ [Emph $ spanCorrect' $ Span (ident, (delete "emph" classes), kvs) ils]
370+ | "strong" `elem` classes =
371+ [Strong $ spanCorrect' $ Span (ident, (delete "strong" classes), kvs) ils]
372+ | "smallcaps" `elem` classes =
373+ [SmallCaps $ spanCorrect' $ Span (ident, (delete "smallcaps" classes), kvs) ils]
374+ | "strike" `elem` classes =
375+ [Strikeout $ spanCorrect' $ Span (ident, (delete "strike" classes), kvs) ils]
376+ | "superscript" `elem` classes =
377+ [Superscript $ spanCorrect' $ Span (ident, (delete "superscript" classes), kvs) ils]
378+ | "subscript" `elem` classes =
379+ [Subscript $ spanCorrect' $ Span (ident, (delete "subscript" classes), kvs) ils]
380+ | (not . null) (codeSpans `intersect` classes) =
381+ [Code (ident, (classes \\ codeSpans), kvs) (init $ unlines $ map ilToCode ils)]
382+ | otherwise =
383+ [Span (ident, classes, kvs) ils]
384+spanCorrect' il = [il]
385+
386+spanCorrect :: [Inline] -> [Inline]
387+spanCorrect = concatMap spanCorrect'
388+
389+removeEmptyPars :: [Block] -> [Block]
390+removeEmptyPars blks = filter (\b -> b /= (Para [])) blks
391+
392+divReduce :: [Block] -> [Block]
393+divReduce [] = []
394+divReduce ((Div (id1, classes1, kvs1) blks1) : blks)
395+ | (id1, classes1, kvs1) == ("", [], []) = blks1 ++ (divReduce blks)
396+divReduce (d1@(Div (id1, classes1, kvs1) blks1) :
397+ d2@(Div (id2, classes2, kvs2) blks2) :
398+ blks) =
399+ let classes' = classes1 `intersect` classes2
400+ kvs' = kvs1 `intersect` kvs2
401+ classes1' = classes1 \\ classes'
402+ kvs1' = kvs1 \\ kvs'
403+ classes2' = classes2 \\ classes'
404+ kvs2' = kvs2 \\ kvs'
405+ in
406+ case null classes' && null kvs' of
407+ True -> d1 : (divReduce (d2 : blks))
408+ False -> let attr' = ("", classes', kvs')
409+ attr1' = (id1, classes1', kvs1')
410+ attr2' = (id2, classes2', kvs2')
411+ in
412+ divReduce (Div attr' [(Div attr1' blks1), (Div attr2' blks2)] :
413+ blks)
414+divReduce (blk:blks) = blk : (divReduce blks)
415+
416+isHeaderClass :: String -> Maybe Int
417+isHeaderClass s | "Heading" `isPrefixOf` s =
418+ case reads (drop (length "Heading") s) :: [(Int, String)] of
419+ [] -> Nothing
420+ ((n, "") : []) -> Just n
421+ _ -> Nothing
422+isHeaderClass _ = Nothing
423+
424+findHeaderClass :: [String] -> Maybe Int
425+findHeaderClass ss = case mapMaybe id $ map isHeaderClass ss of
426+ [] -> Nothing
427+ n : _ -> Just n
428+
429+blksToInlines :: [Block] -> [Inline]
430+blksToInlines (Para ils : _) = ils
431+blksToInlines (Plain ils : _) = ils
432+blksToInlines _ = []
433+
434+divCorrectPreReduce' :: Block -> [Block]
435+divCorrectPreReduce' (Div (ident, classes, kvs) blks)
436+ | isJust $ findHeaderClass classes =
437+ let n = fromJust $ findHeaderClass classes
438+ in
439+ [Header n (ident, delete ("Heading" ++ (show n)) classes, kvs) (blksToInlines blks)]
440+ | otherwise = [Div (ident, classes, kvs) blks]
441+divCorrectPreReduce' blk = [blk]
442+
443+divCorrectPreReduce :: [Block] -> [Block]
444+divCorrectPreReduce = concatMap divCorrectPreReduce'
445+
446+blkToCode :: Block -> String
447+blkToCode (Para []) = ""
448+blkToCode (Para ((Code _ s):ils)) = s ++ (blkToCode (Para ils))
449+blkToCode (Para ((Span (_, classes, _) ils'): ils))
450+ | (not . null) (codeSpans `intersect` classes) =
451+ (init $ unlines $ map ilToCode ils') ++ (blkToCode (Para ils))
452+blkToCode _ = ""
453+
454+divRemove' :: Block -> [Block]
455+divRemove' (Div (_, _, kvs) blks) =
456+ case lookup "indent" kvs of
457+ Just val -> [Div ("", [], [("indent", val)]) blks]
458+ Nothing -> blks
459+divRemove' blk = [blk]
460+
461+divRemove :: [Block] -> [Block]
462+divRemove = concatMap divRemove'
463+
464+divCorrect' :: Block -> [Block]
465+divCorrect' b@(Div (ident, classes, kvs) blks)
466+ | (not . null) (blockQuoteDivs `intersect` classes) =
467+ [BlockQuote [Div (ident, classes \\ blockQuoteDivs, kvs) blks]]
468+ | (not . null) (codeDivs `intersect` classes) =
469+ [CodeBlock (ident, (classes \\ codeDivs), kvs) (init $ unlines $ map blkToCode blks)]
470+ | otherwise =
471+ case lookup "indent" kvs of
472+ Just "0" -> [Div (ident, classes, filter (\kv -> fst kv /= "indent") kvs) blks]
473+ Just _ ->
474+ [BlockQuote [Div (ident, classes, filter (\kv -> fst kv /= "indent") kvs) blks]]
475+ Nothing -> [b]
476+divCorrect' blk = [blk]
477+
478+divCorrect :: [Block] -> [Block]
479+divCorrect = concatMap divCorrect'
src/Text/Pandoc/Readers/DocX/Lists.hsnew file+208
@@ -0,0 +1,208 @@
1+{-
2+Copyright (C) 2014 Jesse Rosenthal <jrosenthal@jhu.edu>
3+
4+This program is free software; you can redistribute it and/or modify
5+it under the terms of the GNU General Public License as published by
6+the Free Software Foundation; either version 2 of the License, or
7+(at your option) any later version.
8+
9+This program is distributed in the hope that it will be useful,
10+but WITHOUT ANY WARRANTY; without even the implied warranty of
11+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12+GNU General Public License for more details.
13+
14+You should have received a copy of the GNU General Public License
15+along with this program; if not, write to the Free Software
16+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17+-}
18+
19+{- |
20+ Module : Text.Pandoc.Readers.DocX.Lists
21+ Copyright : Copyright (C) 2014 Jesse Rosenthal
22+ License : GNU GPL, version 2 or above
23+
24+ Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
25+ Stability : alpha
26+ Portability : portable
27+
28+Functions for converting flat DocX paragraphs into nested lists.
29+-}
30+
31+module Text.Pandoc.Readers.DocX.Lists ( blocksToBullets
32+ , blocksToDefinitions) where
33+
34+import Text.Pandoc.JSON
35+import Text.Pandoc.Shared (trim)
36+import Control.Monad
37+import Data.List
38+import Data.Maybe
39+
40+isListItem :: Block -> Bool
41+isListItem (Div (_, classes, _) _) | "list-item" `elem` classes = True
42+isListItem _ = False
43+
44+getLevel :: Block -> Maybe Integer
45+getLevel (Div (_, _, kvs) _) = liftM read $ lookup "level" kvs
46+getLevel _ = Nothing
47+
48+getLevelN :: Block -> Integer
49+getLevelN b = case getLevel b of
50+ Just n -> n
51+ Nothing -> -1
52+
53+getNumId :: Block -> Maybe Integer
54+getNumId (Div (_, _, kvs) _) = liftM read $ lookup "num-id" kvs
55+getNumId _ = Nothing
56+
57+getNumIdN :: Block -> Integer
58+getNumIdN b = case getNumId b of
59+ Just n -> n
60+ Nothing -> -1
61+
62+getText :: Block -> Maybe String
63+getText (Div (_, _, kvs) _) = lookup "text" kvs
64+getText _ = Nothing
65+
66+data ListType = Itemized | Enumerated ListAttributes
67+
68+listStyleMap :: [(String, ListNumberStyle)]
69+listStyleMap = [("upperLetter", UpperAlpha),
70+ ("lowerLetter", LowerAlpha),
71+ ("upperRoman", UpperRoman),
72+ ("lowerRoman", LowerRoman),
73+ ("decimal", Decimal)]
74+
75+listDelimMap :: [(String, ListNumberDelim)]
76+listDelimMap = [("%1)", OneParen),
77+ ("(%1)", TwoParens),
78+ ("%1.", Period)]
79+
80+getListType :: Block -> Maybe ListType
81+getListType b@(Div (_, _, kvs) _) | isListItem b =
82+ let
83+ start = lookup "start" kvs
84+ frmt = lookup "format" kvs
85+ txt = lookup "text" kvs
86+ in
87+ case frmt of
88+ Just "bullet" -> Just Itemized
89+ Just f ->
90+ case txt of
91+ Just t -> Just $ Enumerated (
92+ read (fromMaybe "1" start) :: Int,
93+ fromMaybe DefaultStyle (lookup f listStyleMap),
94+ fromMaybe DefaultDelim (lookup t listDelimMap))
95+ Nothing -> Nothing
96+ _ -> Nothing
97+getListType _ = Nothing
98+
99+listParagraphDivs :: [String]
100+listParagraphDivs = ["ListParagraph"]
101+
102+-- This is a first stab at going through and attaching meaning to list
103+-- paragraphs, without an item marker, following a list item. We
104+-- assume that these are paragraphs in the same item.
105+
106+handleListParagraphs :: [Block] -> [Block]
107+handleListParagraphs [] = []
108+handleListParagraphs (
109+ (Div attr1@(_, classes1, _) blks1) :
110+ (Div (ident2, classes2, kvs2) blks2) :
111+ blks
112+ ) | "list-item" `elem` classes1 &&
113+ not ("list-item" `elem` classes2) &&
114+ (not . null) (listParagraphDivs `intersect` classes2) =
115+ -- We don't want to keep this indent.
116+ let newDiv2 =
117+ (Div (ident2, classes2, filter (\kv -> fst kv /= "indent") kvs2) blks2)
118+ in
119+ handleListParagraphs ((Div attr1 (blks1 ++ [newDiv2])) : blks)
120+handleListParagraphs (blk:blks) = blk : (handleListParagraphs blks)
121+
122+separateBlocks' :: Block -> [[Block]] -> [[Block]]
123+separateBlocks' blk ([] : []) = [[blk]]
124+separateBlocks' b@(BulletList _) acc = (init acc) ++ [(last acc) ++ [b]]
125+separateBlocks' b@(OrderedList _ _) acc = (init acc) ++ [(last acc) ++ [b]]
126+-- The following is for the invisible bullet lists. This is how
127+-- pandoc-generated ooxml does multiparagraph item lists.
128+separateBlocks' b acc | liftM trim (getText b) == Just "" =
129+ (init acc) ++ [(last acc) ++ [b]]
130+separateBlocks' b acc = acc ++ [[b]]
131+
132+separateBlocks :: [Block] -> [[Block]]
133+separateBlocks blks = foldr separateBlocks' [[]] (reverse blks)
134+
135+flatToBullets' :: Integer -> [Block] -> [Block]
136+flatToBullets' _ [] = []
137+flatToBullets' num xs@(b : elems)
138+ | getLevelN b == num = b : (flatToBullets' num elems)
139+ | otherwise =
140+ let bNumId = getNumIdN b
141+ bLevel = getLevelN b
142+ (children, remaining) =
143+ span
144+ (\b' ->
145+ ((getLevelN b') > bLevel ||
146+ ((getLevelN b') == bLevel && (getNumIdN b') == bNumId)))
147+ xs
148+ in
149+ case getListType b of
150+ Just (Enumerated attr) ->
151+ (OrderedList attr (separateBlocks $ flatToBullets' bLevel children)) :
152+ (flatToBullets' num remaining)
153+ _ ->
154+ (BulletList (separateBlocks $ flatToBullets' bLevel children)) :
155+ (flatToBullets' num remaining)
156+
157+flatToBullets :: [Block] -> [Block]
158+flatToBullets elems = flatToBullets' (-1) elems
159+
160+blocksToBullets :: [Block] -> [Block]
161+blocksToBullets blks =
162+ -- bottomUp removeListItemDivs $
163+ flatToBullets $ (handleListParagraphs blks)
164+
165+
166+plainParaInlines :: Block -> [Inline]
167+plainParaInlines (Plain ils) = ils
168+plainParaInlines (Para ils) = ils
169+plainParaInlines _ = []
170+
171+blocksToDefinitions' :: [([Inline], [[Block]])] -> [Block] -> [Block] -> [Block]
172+blocksToDefinitions' [] acc [] = reverse acc
173+blocksToDefinitions' defAcc acc [] =
174+ reverse $ (DefinitionList (reverse defAcc)) : acc
175+blocksToDefinitions' defAcc acc
176+ ((Div (_, classes1, _) blks1) : (Div (ident2, classes2, kvs2) blks2) : blks)
177+ | "DefinitionTerm" `elem` classes1 && "Definition" `elem` classes2 =
178+ let remainingAttr2 = (ident2, delete "Definition" classes2, kvs2)
179+ pair = case remainingAttr2 == ("", [], []) of
180+ True -> (concatMap plainParaInlines blks1, [blks2])
181+ False -> (concatMap plainParaInlines blks1, [[Div remainingAttr2 blks2]])
182+ in
183+ blocksToDefinitions' (pair : defAcc) acc blks
184+blocksToDefinitions' defAcc acc
185+ ((Div (ident2, classes2, kvs2) blks2) : blks)
186+ | (not . null) defAcc && "Definition" `elem` classes2 =
187+ let remainingAttr2 = (ident2, delete "Definition" classes2, kvs2)
188+ defItems2 = case remainingAttr2 == ("", [], []) of
189+ True -> blks2
190+ False -> [Div remainingAttr2 blks2]
191+ ((defTerm, defItems):defs) = defAcc
192+ defAcc' = case null defItems of
193+ True -> (defTerm, [defItems2]) : defs
194+ False -> (defTerm, init defItems ++ [last defItems ++ defItems2]) : defs
195+ in
196+ blocksToDefinitions' defAcc' acc blks
197+blocksToDefinitions' [] acc (b:blks) =
198+ blocksToDefinitions' [] (b:acc) blks
199+blocksToDefinitions' defAcc acc (b:blks) =
200+ blocksToDefinitions' [] (b : (DefinitionList (reverse defAcc)) : acc) blks
201+
202+
203+blocksToDefinitions :: [Block] -> [Block]
204+blocksToDefinitions = blocksToDefinitions' [] []
205+
206+
207+
208+
src/Text/Pandoc/Readers/DocX/Parse.hsnew file+604
@@ -0,0 +1,604 @@
1+{-
2+Copyright (C) 2014 Jesse Rosenthal <jrosenthal@jhu.edu>
3+
4+This program is free software; you can redistribute it and/or modify
5+it under the terms of the GNU General Public License as published by
6+the Free Software Foundation; either version 2 of the License, or
7+(at your option) any later version.
8+
9+This program is distributed in the hope that it will be useful,
10+but WITHOUT ANY WARRANTY; without even the implied warranty of
11+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12+GNU General Public License for more details.
13+
14+You should have received a copy of the GNU General Public License
15+along with this program; if not, write to the Free Software
16+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17+-}
18+
19+{- |
20+ Module : Text.Pandoc.Readers.DocX.Parse
21+ Copyright : Copyright (C) 2014 Jesse Rosenthal
22+ License : GNU GPL, version 2 or above
23+
24+ Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
25+ Stability : alpha
26+ Portability : portable
27+
28+Conversion of DocX archive into DocX haskell type
29+-}
30+
31+
32+module Text.Pandoc.Readers.DocX.Parse ( DocX(..)
33+ , Document(..)
34+ , Body(..)
35+ , BodyPart(..)
36+ , TblLook(..)
37+ , ParPart(..)
38+ , Run(..)
39+ , RunElem(..)
40+ , Notes
41+ , Numbering
42+ , Relationship
43+ , Media
44+ , RunStyle(..)
45+ , ParagraphStyle(..)
46+ , Row(..)
47+ , Cell(..)
48+ , getFootNote
49+ , getEndNote
50+ , lookupLevel
51+ , lookupRelationship
52+ , archiveToDocX
53+ ) where
54+import Codec.Archive.Zip
55+import Text.XML.Light
56+import Data.Maybe
57+import Data.List
58+import System.FilePath
59+import Data.Bits ((.|.))
60+import qualified Data.ByteString.Lazy as B
61+import qualified Text.Pandoc.UTF8 as UTF8
62+
63+attrToNSPair :: Attr -> Maybe (String, String)
64+attrToNSPair (Attr (QName s _ (Just "xmlns")) val) = Just (s, val)
65+attrToNSPair _ = Nothing
66+
67+
68+type NameSpaces = [(String, String)]
69+
70+data DocX = DocX Document Notes Numbering [Relationship] Media
71+ deriving Show
72+
73+archiveToDocX :: Archive -> Maybe DocX
74+archiveToDocX archive = do
75+ let notes = archiveToNotes archive
76+ rels = archiveToRelationships archive
77+ media = archiveToMedia archive
78+ doc <- archiveToDocument archive
79+ numbering <- archiveToNumbering archive
80+ return $ DocX doc notes numbering rels media
81+
82+data Document = Document NameSpaces Body
83+ deriving Show
84+
85+archiveToDocument :: Archive -> Maybe Document
86+archiveToDocument zf = do
87+ entry <- findEntryByPath "word/document.xml" zf
88+ docElem <- (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry
89+ let namespaces = mapMaybe attrToNSPair (elAttribs docElem)
90+ bodyElem <- findChild (QName "body" (lookup "w" namespaces) Nothing) docElem
91+ body <- elemToBody namespaces bodyElem
92+ return $ Document namespaces body
93+
94+type Media = [(FilePath, B.ByteString)]
95+
96+filePathIsMedia :: FilePath -> Bool
97+filePathIsMedia fp =
98+ let (dir, _) = splitFileName fp
99+ in
100+ (dir == "word/media/")
101+
102+getMediaPair :: Archive -> FilePath -> Maybe (FilePath, B.ByteString)
103+getMediaPair zf fp =
104+ case findEntryByPath fp zf of
105+ Just e -> Just (fp, fromEntry e)
106+ Nothing -> Nothing
107+
108+archiveToMedia :: Archive -> Media
109+archiveToMedia zf =
110+ mapMaybe (getMediaPair zf) (filter filePathIsMedia (filesInArchive zf))
111+
112+data Numbering = Numbering NameSpaces [Numb] [AbstractNumb]
113+ deriving Show
114+
115+data Numb = Numb String String -- right now, only a key to an abstract num
116+ deriving Show
117+
118+data AbstractNumb = AbstractNumb String [Level]
119+ deriving Show
120+
121+-- (ilvl, format, string, start)
122+type Level = (String, String, String, Maybe Integer)
123+
124+lookupLevel :: String -> String -> Numbering -> Maybe Level
125+lookupLevel numId ilvl (Numbering _ numbs absNumbs) = do
126+ absNumId <- lookup numId $ map (\(Numb nid absnumid) -> (nid, absnumid)) numbs
127+ lvls <- lookup absNumId $ map (\(AbstractNumb aid ls) -> (aid, ls)) absNumbs
128+ lvl <- lookup ilvl $ map (\l@(i, _, _, _) -> (i, l)) lvls
129+ return lvl
130+
131+numElemToNum :: NameSpaces -> Element -> Maybe Numb
132+numElemToNum ns element |
133+ qName (elName element) == "num" &&
134+ qURI (elName element) == (lookup "w" ns) = do
135+ numId <- findAttr (QName "numId" (lookup "w" ns) (Just "w")) element
136+ absNumId <- findChild (QName "abstractNumId" (lookup "w" ns) (Just "w")) element
137+ >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
138+ return $ Numb numId absNumId
139+numElemToNum _ _ = Nothing
140+
141+absNumElemToAbsNum :: NameSpaces -> Element -> Maybe AbstractNumb
142+absNumElemToAbsNum ns element |
143+ qName (elName element) == "abstractNum" &&
144+ qURI (elName element) == (lookup "w" ns) = do
145+ absNumId <- findAttr
146+ (QName "abstractNumId" (lookup "w" ns) (Just "w"))
147+ element
148+ let levelElems = findChildren
149+ (QName "lvl" (lookup "w" ns) (Just "w"))
150+ element
151+ levels = mapMaybe id $ map (levelElemToLevel ns) levelElems
152+ return $ AbstractNumb absNumId levels
153+absNumElemToAbsNum _ _ = Nothing
154+
155+levelElemToLevel :: NameSpaces -> Element -> Maybe Level
156+levelElemToLevel ns element |
157+ qName (elName element) == "lvl" &&
158+ qURI (elName element) == (lookup "w" ns) = do
159+ ilvl <- findAttr (QName "ilvl" (lookup "w" ns) (Just "w")) element
160+ fmt <- findChild (QName "numFmt" (lookup "w" ns) (Just "w")) element
161+ >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
162+ txt <- findChild (QName "lvlText" (lookup "w" ns) (Just "w")) element
163+ >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
164+ let start = findChild (QName "start" (lookup "w" ns) (Just "w")) element
165+ >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
166+ >>= (\s -> listToMaybe (map fst (reads s :: [(Integer, String)])))
167+ return (ilvl, fmt, txt, start)
168+levelElemToLevel _ _ = Nothing
169+
170+archiveToNumbering :: Archive -> Maybe Numbering
171+archiveToNumbering zf =
172+ case findEntryByPath "word/numbering.xml" zf of
173+ Nothing -> Just $ Numbering [] [] []
174+ Just entry -> do
175+ numberingElem <- (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry
176+ let namespaces = mapMaybe attrToNSPair (elAttribs numberingElem)
177+ numElems = findChildren
178+ (QName "num" (lookup "w" namespaces) (Just "w"))
179+ numberingElem
180+ absNumElems = findChildren
181+ (QName "abstractNum" (lookup "w" namespaces) (Just "w"))
182+ numberingElem
183+ nums = mapMaybe id $ map (numElemToNum namespaces) numElems
184+ absNums = mapMaybe id $ map (absNumElemToAbsNum namespaces) absNumElems
185+ return $ Numbering namespaces nums absNums
186+
187+data Notes = Notes NameSpaces (Maybe [(String, [BodyPart])]) (Maybe [(String, [BodyPart])])
188+ deriving Show
189+
190+noteElemToNote :: NameSpaces -> Element -> Maybe (String, [BodyPart])
191+noteElemToNote ns element
192+ | qName (elName element) `elem` ["endnote", "footnote"] &&
193+ qURI (elName element) == (lookup "w" ns) =
194+ do
195+ noteId <- findAttr (QName "id" (lookup "w" ns) (Just "w")) element
196+ let bps = map fromJust
197+ $ filter isJust
198+ $ map (elemToBodyPart ns)
199+ $ filterChildrenName (isParOrTbl ns) element
200+ return $ (noteId, bps)
201+noteElemToNote _ _ = Nothing
202+
203+getFootNote :: String -> Notes -> Maybe [BodyPart]
204+getFootNote s (Notes _ fns _) = fns >>= (lookup s)
205+
206+getEndNote :: String -> Notes -> Maybe [BodyPart]
207+getEndNote s (Notes _ _ ens) = ens >>= (lookup s)
208+
209+elemToNotes :: NameSpaces -> String -> Element -> Maybe [(String, [BodyPart])]
210+elemToNotes ns notetype element
211+ | qName (elName element) == (notetype ++ "s") &&
212+ qURI (elName element) == (lookup "w" ns) =
213+ Just $ map fromJust
214+ $ filter isJust
215+ $ map (noteElemToNote ns)
216+ $ findChildren (QName notetype (lookup "w" ns) (Just "w")) element
217+elemToNotes _ _ _ = Nothing
218+
219+archiveToNotes :: Archive -> Notes
220+archiveToNotes zf =
221+ let fnElem = findEntryByPath "word/footnotes.xml" zf
222+ >>= (parseXMLDoc . UTF8.toStringLazy . fromEntry)
223+ enElem = findEntryByPath "word/endnotes.xml" zf
224+ >>= (parseXMLDoc . UTF8.toStringLazy . fromEntry)
225+ fn_namespaces = case fnElem of
226+ Just e -> mapMaybe attrToNSPair (elAttribs e)
227+ Nothing -> []
228+ en_namespaces = case enElem of
229+ Just e -> mapMaybe attrToNSPair (elAttribs e)
230+ Nothing -> []
231+ ns = unionBy (\x y -> fst x == fst y) fn_namespaces en_namespaces
232+ fn = fnElem >>= (elemToNotes ns "footnote")
233+ en = enElem >>= (elemToNotes ns "endnote")
234+ in
235+ Notes ns fn en
236+
237+
238+data Relationship = Relationship (RelId, Target)
239+ deriving Show
240+
241+lookupRelationship :: RelId -> [Relationship] -> Maybe Target
242+lookupRelationship relid rels =
243+ lookup relid (map (\(Relationship pair) -> pair) rels)
244+
245+filePathIsRel :: FilePath -> Bool
246+filePathIsRel fp =
247+ let (dir, name) = splitFileName fp
248+ in
249+ (dir == "word/_rels/") && ((takeExtension name) == ".rels")
250+
251+relElemToRelationship :: Element -> Maybe Relationship
252+relElemToRelationship element | qName (elName element) == "Relationship" =
253+ do
254+ relId <- findAttr (QName "Id" Nothing Nothing) element
255+ target <- findAttr (QName "Target" Nothing Nothing) element
256+ return $ Relationship (relId, target)
257+relElemToRelationship _ = Nothing
258+
259+
260+archiveToRelationships :: Archive -> [Relationship]
261+archiveToRelationships archive =
262+ let relPaths = filter filePathIsRel (filesInArchive archive)
263+ entries = map fromJust $ filter isJust $ map (\f -> findEntryByPath f archive) relPaths
264+ relElems = map fromJust $ filter isJust $ map (parseXMLDoc . UTF8.toStringLazy . fromEntry) entries
265+ rels = map fromJust $ filter isJust $ map relElemToRelationship $ concatMap elChildren relElems
266+ in
267+ rels
268+
269+data Body = Body [BodyPart]
270+ deriving Show
271+
272+isParOrTbl :: NameSpaces -> QName -> Bool
273+isParOrTbl ns q = qName q `elem` ["p", "tbl"] &&
274+ qURI q == (lookup "w" ns)
275+
276+elemToBody :: NameSpaces -> Element -> Maybe Body
277+elemToBody ns element | qName (elName element) == "body" && qURI (elName element) == (lookup "w" ns) =
278+ Just $ Body
279+ $ map fromJust
280+ $ filter isJust
281+ $ map (elemToBodyPart ns) $ filterChildrenName (isParOrTbl ns) element
282+elemToBody _ _ = Nothing
283+
284+isRunOrLinkOrBookmark :: NameSpaces -> QName -> Bool
285+isRunOrLinkOrBookmark ns q = qName q `elem` ["r", "hyperlink", "bookmarkStart"] &&
286+ qURI q == (lookup "w" ns)
287+
288+elemToNumInfo :: NameSpaces -> Element -> Maybe (String, String)
289+elemToNumInfo ns element
290+ | qName (elName element) == "p" &&
291+ qURI (elName element) == (lookup "w" ns) =
292+ do
293+ pPr <- findChild (QName "pPr" (lookup "w" ns) (Just "w")) element
294+ numPr <- findChild (QName "numPr" (lookup "w" ns) (Just "w")) pPr
295+ lvl <- findChild (QName "ilvl" (lookup "w" ns) (Just "w")) numPr >>=
296+ findAttr (QName "val" (lookup "w" ns) (Just "w"))
297+ numId <- findChild (QName "numId" (lookup "w" ns) (Just "w")) numPr >>=
298+ findAttr (QName "val" (lookup "w" ns) (Just "w"))
299+ return (numId, lvl)
300+elemToNumInfo _ _ = Nothing
301+
302+-- isBookMarkTag :: NameSpaces -> QName -> Bool
303+-- isBookMarkTag ns q = qName q `elem` ["bookmarkStart", "bookmarkEnd"] &&
304+-- qURI q == (lookup "w" ns)
305+
306+-- parChildrenToBookmark :: NameSpaces -> [Element] -> BookMark
307+-- parChildrenToBookmark ns (bms : bme : _)
308+-- | qName (elName bms) == "bookmarkStart" &&
309+-- qURI (elName bms) == (lookup "w" ns) &&
310+-- qName (elName bme) == "bookmarkEnd" &&
311+-- qURI (elName bme) == (lookup "w" ns) = do
312+-- bmId <- findAttr (QName "id" (lookup "w" ns) (Just "w")) bms
313+-- bmName <- findAttr (QName "name" (lookup "w" ns) (Just "w")) bms
314+-- return $ (bmId, bmName)
315+-- parChildrenToBookmark _ _ = Nothing
316+
317+elemToBodyPart :: NameSpaces -> Element -> Maybe BodyPart
318+elemToBodyPart ns element
319+ | qName (elName element) == "p" &&
320+ qURI (elName element) == (lookup "w" ns) =
321+ let parstyle = elemToParagraphStyle ns element
322+ parparts = mapMaybe id
323+ $ map (elemToParPart ns)
324+ $ filterChildrenName (isRunOrLinkOrBookmark ns) element
325+ in
326+ case elemToNumInfo ns element of
327+ Just (numId, lvl) -> Just $ ListItem parstyle numId lvl parparts
328+ Nothing -> Just $ Paragraph parstyle parparts
329+ | qName (elName element) == "tbl" &&
330+ qURI (elName element) == (lookup "w" ns) =
331+ let
332+ caption = findChild (QName "tblPr" (lookup "w" ns) (Just "w")) element
333+ >>= findChild (QName "tblCaption" (lookup "w" ns) (Just "w"))
334+ >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
335+ grid = case
336+ findChild (QName "tblGrid" (lookup "w" ns) (Just "w")) element
337+ of
338+ Just g -> elemToTblGrid ns g
339+ Nothing -> []
340+ tblLook = findChild (QName "tblPr" (lookup "w" ns) (Just "w")) element
341+ >>= findChild (QName "tblLook" (lookup "w" ns) (Just "w"))
342+ >>= elemToTblLook ns
343+ in
344+ Just $ Tbl
345+ (fromMaybe "" caption)
346+ grid
347+ (fromMaybe defaultTblLook tblLook)
348+ (mapMaybe (elemToRow ns) (elChildren element))
349+ | otherwise = Nothing
350+
351+elemToTblLook :: NameSpaces -> Element -> Maybe TblLook
352+elemToTblLook ns element
353+ | qName (elName element) == "tblLook" &&
354+ qURI (elName element) == (lookup "w" ns) =
355+ let firstRow = findAttr (QName "firstRow" (lookup "w" ns) (Just "w")) element
356+ val = findAttr (QName "val" (lookup "w" ns) (Just "w")) element
357+ firstRowFmt =
358+ case firstRow of
359+ Just "1" -> True
360+ Just _ -> False
361+ Nothing -> case val of
362+ Just bitMask -> testBitMask bitMask 0x020
363+ Nothing -> False
364+ in
365+ Just $ TblLook{firstRowFormatting = firstRowFmt}
366+elemToTblLook _ _ = Nothing
367+
368+testBitMask :: String -> Int -> Bool
369+testBitMask bitMaskS n =
370+ case (reads ("0x" ++ bitMaskS) :: [(Int, String)]) of
371+ [] -> False
372+ ((n', _) : _) -> ((n' .|. n) /= 0)
373+
374+data ParagraphStyle = ParagraphStyle { pStyle :: [String]
375+ , indent :: Maybe Integer
376+ }
377+ deriving Show
378+
379+defaultParagraphStyle :: ParagraphStyle
380+defaultParagraphStyle = ParagraphStyle { pStyle = []
381+ , indent = Nothing
382+ }
383+
384+elemToParagraphStyle :: NameSpaces -> Element -> ParagraphStyle
385+elemToParagraphStyle ns element =
386+ case findChild (QName "pPr" (lookup "w" ns) (Just "w")) element of
387+ Just pPr ->
388+ ParagraphStyle
389+ {pStyle =
390+ mapMaybe id $
391+ map
392+ (findAttr (QName "val" (lookup "w" ns) (Just "w")))
393+ (findChildren (QName "pStyle" (lookup "w" ns) (Just "w")) pPr)
394+ , indent =
395+ findChild (QName "ind" (lookup "w" ns) (Just "w")) pPr >>=
396+ findAttr (QName "left" (lookup "w" ns) (Just "w")) >>=
397+ stringToInteger
398+ }
399+ Nothing -> defaultParagraphStyle
400+
401+
402+data BodyPart = Paragraph ParagraphStyle [ParPart]
403+ | ListItem ParagraphStyle String String [ParPart]
404+ | Tbl String TblGrid TblLook [Row]
405+
406+ deriving Show
407+
408+type TblGrid = [Integer]
409+
410+data TblLook = TblLook {firstRowFormatting::Bool}
411+ deriving Show
412+
413+defaultTblLook :: TblLook
414+defaultTblLook = TblLook{firstRowFormatting = False}
415+
416+stringToInteger :: String -> Maybe Integer
417+stringToInteger s = listToMaybe $ map fst (reads s :: [(Integer, String)])
418+
419+elemToTblGrid :: NameSpaces -> Element -> TblGrid
420+elemToTblGrid ns element
421+ | qName (elName element) == "tblGrid" &&
422+ qURI (elName element) == (lookup "w" ns) =
423+ let
424+ cols = findChildren (QName "gridCol" (lookup "w" ns) (Just "w")) element
425+ in
426+ mapMaybe (\e ->
427+ findAttr (QName "val" (lookup "w" ns) (Just ("w"))) e
428+ >>= stringToInteger
429+ )
430+ cols
431+elemToTblGrid _ _ = []
432+
433+data Row = Row [Cell]
434+ deriving Show
435+
436+
437+elemToRow :: NameSpaces -> Element -> Maybe Row
438+elemToRow ns element
439+ | qName (elName element) == "tr" &&
440+ qURI (elName element) == (lookup "w" ns) =
441+ let
442+ cells = findChildren (QName "tc" (lookup "w" ns) (Just "w")) element
443+ in
444+ Just $ Row (mapMaybe (elemToCell ns) cells)
445+elemToRow _ _ = Nothing
446+
447+data Cell = Cell [BodyPart]
448+ deriving Show
449+
450+elemToCell :: NameSpaces -> Element -> Maybe Cell
451+elemToCell ns element
452+ | qName (elName element) == "tc" &&
453+ qURI (elName element) == (lookup "w" ns) =
454+ Just $ Cell (mapMaybe (elemToBodyPart ns) (elChildren element))
455+elemToCell _ _ = Nothing
456+
457+data ParPart = PlainRun Run
458+ | BookMark BookMarkId Anchor
459+ | InternalHyperLink Anchor [Run]
460+ | ExternalHyperLink RelId [Run]
461+ | Drawing String
462+ deriving Show
463+
464+data Run = Run RunStyle [RunElem]
465+ | Footnote String
466+ | Endnote String
467+ deriving Show
468+
469+data RunElem = TextRun String | LnBrk
470+ deriving Show
471+
472+data RunStyle = RunStyle { isBold :: Bool
473+ , isItalic :: Bool
474+ , isSmallCaps :: Bool
475+ , isStrike :: Bool
476+ , isSuperScript :: Bool
477+ , isSubScript :: Bool
478+ , underline :: Maybe String
479+ , rStyle :: Maybe String }
480+ deriving Show
481+
482+defaultRunStyle :: RunStyle
483+defaultRunStyle = RunStyle { isBold = False
484+ , isItalic = False
485+ , isSmallCaps = False
486+ , isStrike = False
487+ , isSuperScript = False
488+ , isSubScript = False
489+ , underline = Nothing
490+ , rStyle = Nothing
491+ }
492+
493+elemToRunStyle :: NameSpaces -> Element -> RunStyle
494+elemToRunStyle ns element =
495+ case findChild (QName "rPr" (lookup "w" ns) (Just "w")) element of
496+ Just rPr ->
497+ RunStyle
498+ {
499+ isBold = isJust $ findChild (QName "b" (lookup "w" ns) (Just "w")) rPr
500+ , isItalic = isJust $ findChild (QName "i" (lookup "w" ns) (Just "w")) rPr
501+ , isSmallCaps = isJust $ findChild (QName "smallCaps" (lookup "w" ns) (Just "w")) rPr
502+ , isStrike = isJust $ findChild (QName "strike" (lookup "w" ns) (Just "w")) rPr
503+ , isSuperScript =
504+ (Just "superscript" ==
505+ (findChild (QName "vertAlign" (lookup "w" ns) (Just "w")) rPr >>=
506+ findAttr (QName "val" (lookup "w" ns) (Just "w"))))
507+ , isSubScript =
508+ (Just "subscript" ==
509+ (findChild (QName "vertAlign" (lookup "w" ns) (Just "w")) rPr >>=
510+ findAttr (QName "val" (lookup "w" ns) (Just "w"))))
511+ , underline =
512+ findChild (QName "u" (lookup "w" ns) (Just "w")) rPr >>=
513+ findAttr (QName "val" (lookup "w" ns) (Just "w"))
514+ , rStyle =
515+ findChild (QName "rStyle" (lookup "w" ns) (Just "w")) rPr >>=
516+ findAttr (QName "val" (lookup "w" ns) (Just "w"))
517+ }
518+ Nothing -> defaultRunStyle
519+
520+elemToRun :: NameSpaces -> Element -> Maybe Run
521+elemToRun ns element
522+ | qName (elName element) == "r" &&
523+ qURI (elName element) == (lookup "w" ns) =
524+ case
525+ findChild (QName "footnoteReference" (lookup "w" ns) (Just "w")) element >>=
526+ findAttr (QName "id" (lookup "w" ns) (Just "w"))
527+ of
528+ Just s -> Just $ Footnote s
529+ Nothing ->
530+ case
531+ findChild (QName "endnoteReference" (lookup "w" ns) (Just "w")) element >>=
532+ findAttr (QName "id" (lookup "w" ns) (Just "w"))
533+ of
534+ Just s -> Just $ Endnote s
535+ Nothing -> Just $
536+ Run (elemToRunStyle ns element)
537+ (elemToRunElems ns element)
538+elemToRun _ _ = Nothing
539+
540+elemToRunElem :: NameSpaces -> Element -> Maybe RunElem
541+elemToRunElem ns element
542+ | qName (elName element) == "t" &&
543+ qURI (elName element) == (lookup "w" ns) =
544+ Just $ TextRun (strContent element)
545+ | qName (elName element) == "br" &&
546+ qURI (elName element) == (lookup "w" ns) =
547+ Just $ LnBrk
548+ | otherwise = Nothing
549+
550+
551+elemToRunElems :: NameSpaces -> Element -> [RunElem]
552+elemToRunElems ns element
553+ | qName (elName element) == "r" &&
554+ qURI (elName element) == (lookup "w" ns) =
555+ mapMaybe (elemToRunElem ns) (elChildren element)
556+ | otherwise = []
557+
558+elemToDrawing :: NameSpaces -> Element -> Maybe ParPart
559+elemToDrawing ns element
560+ | qName (elName element) == "drawing" &&
561+ qURI (elName element) == (lookup "w" ns) =
562+ let a_ns = "http://schemas.openxmlformats.org/drawingml/2006/main"
563+ in
564+ findElement (QName "blip" (Just a_ns) (Just "a")) element
565+ >>= findAttr (QName "embed" (lookup "r" ns) (Just "r"))
566+ >>= (\s -> Just $ Drawing s)
567+elemToDrawing _ _ = Nothing
568+
569+
570+elemToParPart :: NameSpaces -> Element -> Maybe ParPart
571+elemToParPart ns element
572+ | qName (elName element) == "r" &&
573+ qURI (elName element) == (lookup "w" ns) =
574+ case findChild (QName "drawing" (lookup "w" ns) (Just "w")) element of
575+ Just drawingElem -> elemToDrawing ns drawingElem
576+ Nothing -> do
577+ r <- elemToRun ns element
578+ return $ PlainRun r
579+elemToParPart ns element
580+ | qName (elName element) == "bookmarkStart" &&
581+ qURI (elName element) == (lookup "w" ns) = do
582+ bmId <- findAttr (QName "id" (lookup "w" ns) (Just "w")) element
583+ bmName <- findAttr (QName "name" (lookup "w" ns) (Just "w")) element
584+ return $ BookMark bmId bmName
585+elemToParPart ns element
586+ | qName (elName element) == "hyperlink" &&
587+ qURI (elName element) == (lookup "w" ns) =
588+ let runs = map fromJust $ filter isJust $ map (elemToRun ns)
589+ $ findChildren (QName "r" (lookup "w" ns) (Just "w")) element
590+ in
591+ case findAttr (QName "anchor" (lookup "w" ns) (Just "w")) element of
592+ Just anchor ->
593+ Just $ InternalHyperLink anchor runs
594+ Nothing ->
595+ case findAttr (QName "id" (lookup "r" ns) (Just "r")) element of
596+ Just relId -> Just $ ExternalHyperLink relId runs
597+ Nothing -> Nothing
598+elemToParPart _ _ = Nothing
599+
600+type Target = String
601+type Anchor = String
602+type BookMarkId = String
603+type RelId = String
604+