6c4345a · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Merge pull request #1415 from jkr/nicertype

6c4345aJohn MacFarlane12 years ago

pandoc.cabal+1

compare with master

unifiedsplit

@@ -340,6 +340,7 @@ Library

340 Text.Pandoc.Slides,

341 Text.Pandoc.Highlighting,

342 Text.Pandoc.Compat.Monoid,

343+ Text.Pandoc.Compat.Except,

343 Text.Pandoc.Compat.TagSoupEntity,

344 Text.Pandoc.Compat.TagSoupEntity,

344 Paths_pandoc

345 Paths_pandoc

345

346

src/Text/Pandoc/Compat/Except.hsnew file+27

@@ -0,0 +1,27 @@

1+{-# LANGUAGE CPP #-}

2+module Text.Pandoc.Compat.Except ( ExceptT

3+ , Error(..)

4+ , runExceptT

5+ , throwError

6+ , catchError )

7+ where

9+#if MIN_VERSION_mtl(2,2,1)

10+import Control.Monad.Except

11+

12+class Error a where

13+ noMsg :: a

14+ strMsg :: String -> a

15+

16+ noMsg = strMsg ""

17+ strMsg _ = noMsg

18+

19+#else

20+import Control.Monad.Error

21+type ExceptT = ErrorT

22+

23+runExceptT :: ExceptT e m a -> m (Either e a)

24+runExceptT = runErrorT

25+#endif

26+

27+

src/Text/Pandoc/Readers/Docx.hs+42−66

@@ -91,7 +91,6 @@ import Data.List (delete, isPrefixOf, (\\), intercalate)

91import qualified Data.ByteString as BS

92import qualified Data.ByteString.Lazy as B

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

11This program is distributed in the hope that it will be useful,

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.

16You should have received a copy of the GNU General Public License

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-}

21{- |

22− Module : Text.Pandoc.Readers.Docx.Parse

22+ Module : Text.Pandoc.Readers.Docx.Parse

24− License : GNU GPL, version 2 or above

24+ License : GNU GPL, version 2 or above

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

30Conversion of docx archive into Docx haskell type

31-}

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

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 Text.Pandoc.Compat.Except

73+

74+data ReaderEnv = ReaderEnv { envNotes :: Notes

75+ , envNumbering :: Numbering

76+ , envRelationships :: [Relationship]

77+ , envMedia :: Media

78+ }

79+ deriving Show

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 = ExceptT DocxError (Reader ReaderEnv)

88+

89+runD :: D a -> ReaderEnv -> Either DocxError a

90+runD dx re = runReader (runExceptT dx ) re

91+

92+maybeToD :: Maybe a -> D a

93+maybeToD (Just a) = return a

94+maybeToD Nothing = throwError DocxError

95+

96+mapD :: (a -> D b) -> [a] -> D [b]

97+mapD _ [] = return []

98+mapD f (x:xs) = do

99+ y <- (f x >>= (\z -> return [z])) `catchError` (\_ -> return [])

100+ ys <- mapD f xs

101+ return $ y ++ ys

102

103

80type NameSpaces = [(String, String)]

104type NameSpaces = [(String, String)]

105

82−data Docx = Docx Document Notes Numbering [Relationship] Media

106+data Docx = Docx Document

83 deriving Show

107 deriving Show

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

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

468+

469+elemToTblGrid :: NameSpaces -> Element -> D TblGrid

470+elemToTblGrid ns element | isElem ns "w" "tblGrid" element =

471+ let cols = findChildren (elemName ns "w" "gridCol") element

472+ in

473+ mapD (\e -> maybeToD (findAttr (elemName ns "w" "val") e >>= stringToInteger))

474+ cols

475+elemToTblGrid _ _ = throwError WrongElem

476+

477+elemToTblLook :: NameSpaces -> Element -> D TblLook

478+elemToTblLook ns element | isElem ns "w" "tblLook" element =

479+ let firstRow = findAttr (elemName ns "w" "firstRow") element

480+ val = findAttr (elemName ns "w" "val") element

481+ firstRowFmt =

482+ case firstRow of

483+ Just "1" -> True

484+ Just _ -> False

485+ Nothing -> case val of

486+ Just bitMask -> testBitMask bitMask 0x020

487+ Nothing -> False

488+ in

489+ return $ TblLook{firstRowFormatting = firstRowFmt}

490+elemToTblLook _ _ = throwError WrongElem

491+

492+elemToRow :: NameSpaces -> Element -> D Row

493+elemToRow ns element | isElem ns "w" "tr" element =

494+ do

495+ let cellElems = findChildren (elemName ns "w" "tc") element

496+ cells <- mapD (elemToCell ns) cellElems

497+ return $ Row cells

498+elemToRow _ _ = throwError WrongElem

499+

500+elemToCell :: NameSpaces -> Element -> D Cell

501+elemToCell ns element | isElem ns "w" "tc" element =

502+ do

503+ cellContents <- mapD (elemToBodyPart ns) (elChildren element)

504+ return $ Cell cellContents

505+elemToCell _ _ = throwError WrongElem

506+

507+elemToParIndentation :: NameSpaces -> Element -> Maybe ParIndentation

508+elemToParIndentation ns element | isElem ns "w" "ind" element =

509+ Just $ ParIndentation {

510+ leftParIndent =

511+ findAttr (QName "left" (lookup "w" ns) (Just "w")) element >>=

512+ stringToInteger

513+ , rightParIndent =

514+ findAttr (QName "right" (lookup "w" ns) (Just "w")) element >>=

515+ stringToInteger

516+ , hangingParIndent =

517+ findAttr (QName "hanging" (lookup "w" ns) (Just "w")) element >>=

518+ stringToInteger}

519+elemToParIndentation _ _ = Nothing

520+

521+

522+elemToNumInfo :: NameSpaces -> Element -> Maybe (String, String)

523+elemToNumInfo ns element | isElem ns "w" "p" element = do

524+ let pPr = findChild (elemName ns "w" "pPr") element

525+ numPr = pPr >>= findChild (elemName ns "w" "numPr")

526+ lvl <- numPr >>=

527+ findChild (elemName ns "w" "ilvl") >>=

528+ findAttr (elemName ns "w" "val")

529+ numId <- numPr >>=

530+ findChild (elemName ns "w" "numId") >>=

531+ findAttr (elemName ns "w" "val")

532+ return (numId, lvl)

533+elemToNumInfo _ _ = Nothing

534+

535+testBitMask :: String -> Int -> Bool

536+testBitMask bitMaskS n =

537+ case (reads ("0x" ++ bitMaskS) :: [(Int, String)]) of

538+ [] -> False

539+ ((n', _) : _) -> ((n' .|. n) /= 0)

540+

541+stringToInteger :: String -> Maybe Integer

542+stringToInteger s = listToMaybe $ map fst (reads s :: [(Integer, String)])

543+

544+elemToBodyPart :: NameSpaces -> Element -> D BodyPart

545+elemToBodyPart ns element

546+ | isElem ns "w" "p" element

547+ , (c:_) <- findChildren (elemName ns "m" "oMathPara") element =

548+ do

549+ let style = [] -- placeholder

550+ maths <- mapD (elemToMath ns) (elChildren c)

551+ return $ OMathPara style maths

552+elemToBodyPart ns element

553+ | isElem ns "w" "p" element

554+ , Just (numId, lvl) <- elemToNumInfo ns element = do

555+ let parstyle = elemToParagraphStyle ns element

556+ parparts <- mapD (elemToParPart ns) (elChildren element)

557+ num <- asks envNumbering

558+ case lookupLevel numId lvl num of

559+ Just levelInfo -> return $ ListItem parstyle numId lvl levelInfo parparts

560+ Nothing -> throwError WrongElem

561+elemToBodyPart ns element

562+ | isElem ns "w" "p" element = do

563+ let parstyle = elemToParagraphStyle ns element

564+ parparts <- mapD (elemToParPart ns) (elChildren element)

565+ return $ Paragraph parstyle parparts

566+elemToBodyPart ns element

567+ | isElem ns "w" "tbl" element = do

568+ let caption' = findChild (elemName ns "w" "tblPr") element

569+ >>= findChild (elemName ns "w" "tblCaption")

570+ >>= findAttr (elemName ns "w" "val")

571+ caption = (fromMaybe "" caption')

572+ grid' = case findChild (elemName ns "w" "tblGrid") element of

573+ Just g -> elemToTblGrid ns g

574+ Nothing -> return []

575+ tblLook' = case findChild (elemName ns "w" "tblPr") element >>=

576+ findChild (elemName ns "w" "tblLook")

577+ of

578+ Just l -> elemToTblLook ns l

579+ Nothing -> return defaultTblLook

580+

581+ grid <- grid'

582+ tblLook <- tblLook'

583+ rows <- mapD (elemToRow ns) (elChildren element)

584+ return $ Tbl caption grid tblLook rows

585+elemToBodyPart _ _ = throwError WrongElem

586+

669−elemToBase :: NameSpaces -> Element -> Maybe Base

587+elemToMath :: NameSpaces -> Element -> D OMath

670−elemToBase ns element

588+elemToMath ns element | isElem ns "m" "oMath" element =

671− | qName (elName element) == "e" &&

589+ mapD (elemToMathElem ns) (elChildren element) >>=

672− qURI (elName element) == (lookup "m" ns) =

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 =

673− Just $ Base $ mapMaybe (elemToMathElem ns) (elChildren element)

595+ mapD (elemToMathElem ns) (elChildren element) >>=

596+ (\es -> return $ Base es)

674−elemToBase _ _ = Nothing

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" &&

727− qURI (elName element) == (lookup "m" ns) = do

728− let accChar =

649+ let accChar =

729− findChild (QName "accPr" (lookup "m" ns) (Just "m")) element >>=

650+ findChild (QName "accPr" (lookup "m" ns) (Just "m")) element >>=

730− findChild (QName "chr" (lookup "m" ns) (Just "m")) >>=

651+ findChild (QName "chr" (lookup "m" ns) (Just "m")) >>=

731− findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=

652+ findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=

732− Just . head

653+ Just . head

733− accPr = AccentStyle { accentChar = accChar}

654+ accPr = AccentStyle { accentChar = accChar}

734− base <-findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=

655+ base <-(maybeToD $ findChild (elemName ns "m" "e") element) >>=

735− elemToBase ns

656+ elemToBase ns

736− return $ Accent accPr base

657+ return $ Accent accPr base

737−elemToMathElem ns element

658+elemToMathElem ns element | isElem ns "m" "bar" element = do

738− | qName (elName element) == "bar" &&

659+ barPr <- maybeToD $

739− qURI (elName element) == (lookup "m" ns) = do

740− barPr <- findChild (QName "barPr" (lookup "m" ns) (Just "m")) element >>=

660+ findChild (QName "barPr" (lookup "m" ns) (Just "m")) element >>=

741− findChild (QName "pos" (lookup "m" ns) (Just "m")) >>=

661+ findChild (QName "pos" (lookup "m" ns) (Just "m")) >>=

742− findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=

662+ findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=

743− (\s ->

663+ (\s ->

744− Just $ BarStyle {

664+ Just $ BarStyle {

745− barPos = (if s == "bot" then Bottom else Top)

665+ barPos = (if s == "bot" then Bottom else Top)

746− })

666+ })

747− base <-findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=

667+ base <-maybeToD (findChild (QName "e" (lookup "m" ns) (Just "m")) element) >>=

748− elemToBase ns

668+ elemToBase ns

749− return $ Bar barPr base

669+ return $ Bar barPr base

750−elemToMathElem ns element

670+elemToMathElem ns element | isElem ns "m" "box" element =

751− | qName (elName element) == "box" &&

752− qURI (elName element) == (lookup "m" ns) =

753− findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=

671+ maybeToD (findChild (elemName ns "m" "e") element) >>=

754− elemToBase ns >>=

672+ elemToBase ns >>=

755− (\b -> Just $ Box b)

673+ (\b -> return $ Box b)

756−elemToMathElem ns element

674+elemToMathElem ns element | isElem ns "m" "borderBox" element =

757− | qName (elName element) == "borderBox" &&

758− qURI (elName element) == (lookup "m" ns) =

759− findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=

675+ maybeToD (findChild (elemName ns "m" "e") element) >>=

760− elemToBase ns >>=

676+ elemToBase ns >>=

761− (\b -> Just $ BorderBox b)

677+ (\b -> return $ BorderBox b)

762−elemToMathElem ns element

678+elemToMathElem ns element | isElem ns "m" "d" element =

763− | qName (elName element) == "d" &&

764− qURI (elName element) == (lookup "m" ns) =

765− let style = elemToDelimStyle ns element

679+ let style = elemToDelimStyle ns element

766− in

680+ in

767− Just $ Delimiter style $ mapMaybe (elemToBase ns) (elChildren element)

681+ mapD (elemToBase ns) (elChildren element) >>=

682+ (\es -> return $ Delimiter style es)

768−elemToMathElem ns element

683+elemToMathElem ns element | isElem ns "m" "eqArr" element =

769− | qName (elName element) == "eqArr" &&

684+ mapD (elemToBase ns) (elChildren element) >>=

770− qURI (elName element) == (lookup "m" ns) =

771− Just $ EquationArray

685+ (\es -> return $ EquationArray es)

772− $ mapMaybe (elemToBase ns) (elChildren element)

773−elemToMathElem ns element

686+elemToMathElem ns element | isElem ns "m" "f" element = do

774− | qName (elName element) == "f" &&

687+ num <- maybeToD $ findChild (elemName ns "m" "num") element

775− qURI (elName element) == (lookup "m" ns) = do

688+ den <- maybeToD $ findChild (elemName ns "m" "den") element

776− num <- findChild (QName "num" (lookup "m" ns) (Just "m")) element

777− den <- findChild (QName "den" (lookup "m" ns) (Just "m")) element

778− let numElems = mapMaybe (elemToMathElem ns) (elChildren num)

689+ numElems <- mapD (elemToMathElem ns) (elChildren num)

779− denElems = mapMaybe (elemToMathElem ns) (elChildren den)

690+ denElems <- mapD (elemToMathElem ns) (elChildren den)

780− return $ Fraction numElems denElems

691+ return $ Fraction numElems denElems

781−elemToMathElem ns element

692+elemToMathElem ns element | isElem ns "m" "func" element = do

782− | qName (elName element) == "func" &&

783− qURI (elName element) == (lookup "m" ns) = do

784− fName <- findChild (QName "fName" (lookup "m" ns) (Just "m")) element

693+ fName <- maybeToD $ findChild (elemName ns "m" "fName") element

785− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=

694+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=

786− elemToBase ns

695+ elemToBase ns

787− let fnElems = mapMaybe (elemToMathElem ns) (elChildren fName)

696+ fnElems <- mapD (elemToMathElem ns) (elChildren fName)

788− return $ Function fnElems base

697+ return $ Function fnElems base

789−elemToMathElem ns element

698+elemToMathElem ns element | isElem ns "m" "groupChr" element =

790− | qName (elName element) == "groupChr" &&

791− qURI (elName element) == (lookup "m" ns) =

792− let style = elemToGroupStyle ns element

699+ let style = elemToGroupStyle ns element

793− in

700+ in

794− findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=

701+ maybeToD (findChild (elemName ns "m" "e") element) >>=

795− elemToBase ns >>=

702+ elemToBase ns >>=

796− (\b -> Just $ Group style b)

703+ (\b -> return $ Group style b)

797−elemToMathElem ns element

704+elemToMathElem ns element | isElem ns "m" "limLow" element = do

798− | qName (elName element) == "limLow" &&

705+ base <- maybeToD (findChild (elemName ns "m" "e") element)

799− qURI (elName element) == (lookup "m" ns) = do

800− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element

801− >>= elemToBase ns

706+ >>= elemToBase ns

802− lim <- findChild (QName "lim" (lookup "m" ns) (Just "m")) element

707+ lim <- maybeToD $ findChild (elemName ns "m" "lim") element

708+ limElems <- mapD (elemToMathElem ns) (elChildren lim)

803− return $ LowerLimit base (mapMaybe (elemToMathElem ns) (elChildren lim))

709+ return $ LowerLimit base limElems

804−elemToMathElem ns element

710+elemToMathElem ns element | isElem ns "m" "limUpp" element = do

805− | qName (elName element) == "limUpp" &&

711+ base <- maybeToD (findChild (elemName ns "m" "e") element)

806− qURI (elName element) == (lookup "m" ns) = do

807− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element

808− >>= elemToBase ns

712+ >>= elemToBase ns

809− lim <- findChild (QName "lim" (lookup "m" ns) (Just "m")) element

713+ lim <- maybeToD $ findChild (elemName ns "m" "lim") element

714+ limElems <- mapD (elemToMathElem ns) (elChildren lim)

810− return $ UpperLimit base (mapMaybe (elemToMathElem ns) (elChildren lim))

715+ return $ UpperLimit base limElems

811−elemToMathElem ns element

716+elemToMathElem ns element | isElem ns "m" "m" element = do

812− | qName (elName element) == "m" &&

813− qURI (elName element) == (lookup "m" ns) =

814− let rows = findChildren (QName "mr" (lookup "m" ns) (Just "m")) element

717+ let rows = findChildren (elemName ns "m" "mr") element

815− bases = map (\mr -> mapMaybe (elemToBase ns) (elChildren mr)) rows

718+ bases <- mapD (\mr -> mapD (elemToBase ns) (elChildren mr)) rows

816− in

817− Just $ Matrix bases

719+ return $ Matrix bases

818−elemToMathElem ns element

720+elemToMathElem ns element | isElem ns "m" "nary" element = do

819− | qName (elName element) == "nary" &&

820− qURI (elName element) == (lookup "m" ns) = do

821− let style = elemToNAryStyle ns element

721+ let style = elemToNAryStyle ns element

822− sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=

722+ sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>=

823− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))

723+ (\e -> mapD (elemToMathElem ns) (elChildren e))

824− sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=

724+ sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>=

825− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))

725+ (\e -> mapD (elemToMathElem ns) (elChildren e))

826− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=

726+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=

827− elemToBase ns

727+ elemToBase ns

828− return $ NAry style sub sup base

728+ return $ NAry style sub sup base

829−elemToMathElem ns element

729+elemToMathElem ns element | isElem ns "m" "rad" element = do

830− | qName (elName element) == "rad" &&

831− qURI (elName element) == (lookup "m" ns) = do

832− deg <- findChild (QName "deg" (lookup "m" ns) (Just "m")) element >>=

730+ deg <- maybeToD (findChild (elemName ns "m" "deg") element) >>=

833− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))

731+ (\e -> mapD (elemToMathElem ns) (elChildren e))

834− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=

732+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=

835− elemToBase ns

733+ elemToBase ns

836− return $ Radical deg base

734+ return $ Radical deg base

837−-- skipping for now:

735+elemToMathElem ns element | isElem ns "m" "phant" element = do

838−-- phant

736+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=

839−elemToMathElem ns element

737+ elemToBase ns

840− | qName (elName element) == "sPre" &&

738+ return $ Phantom base

841− qURI (elName element) == (lookup "m" ns) = do

739+elemToMathElem ns element | isElem ns "m" "sPre" element = do

842− sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=

740+ sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>=

843− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))

741+ (\e -> mapD (elemToMathElem ns) (elChildren e))

844− sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=

742+ sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>=

845− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))

743+ (\e -> mapD (elemToMathElem ns) (elChildren e))

846− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=

744+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=

847− elemToBase ns

745+ elemToBase ns

848− return $ PreSubSuper sub sup base

746+ return $ PreSubSuper sub sup base

849−elemToMathElem ns element

747+elemToMathElem ns element | isElem ns "m" "sSub" element = do

850− | qName (elName element) == "sSub" &&

851− qURI (elName element) == (lookup "m" ns) = do

852− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=

748+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=

853− elemToBase ns

749+ elemToBase ns

854− sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=

750+ sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>=

855− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))

751+ (\e -> mapD (elemToMathElem ns) (elChildren e))

856− return $ Sub base sub

752+ return $ Sub base sub

857−elemToMathElem ns element

753+elemToMathElem ns element | isElem ns "m" "sSubSup" element = do

858− | qName (elName element) == "sSubSup" &&

754+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=

859− qURI (elName element) == (lookup "m" ns) = do

860− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=

861− elemToBase ns

755+ elemToBase ns

862− sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=

756+ sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>=

863− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))

757+ (\e -> mapD (elemToMathElem ns) (elChildren e))

864− sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=

758+ sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>=

865− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))

759+ (\e -> mapD (elemToMathElem ns) (elChildren e))

866− return $ SubSuper base sub sup

760+ return $ SubSuper base sub sup

867−elemToMathElem ns element

761+elemToMathElem ns element | isElem ns "m" "sSup" element = do

868− | qName (elName element) == "sSup" &&

762+ base <- maybeToD (findChild (elemName ns "m" "e") element) >>=

869− qURI (elName element) == (lookup "m" ns) = do

870− base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=

871− elemToBase ns

763+ elemToBase ns

872− sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=

764+ sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>=

873− (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))

765+ (\e -> mapD (elemToMathElem ns) (elChildren e))

874− return $ Super base sup

766+ return $ Sub base sup

875−elemToMathElem ns element

767+elemToMathElem ns element | isElem ns "m" "r" element = do

876− | qName (elName element) == "r" &&

877− qURI (elName element) == (lookup "m" ns) =

878− let style = [] -- placeholder

768+ let style = [] -- placeholder

879− rstyle = elemToRunStyle ns element

769+ rstyle = elemToRunStyle ns element

880− relems = elemToRunElems ns element

770+ relems <- elemToRunElems ns element

881− in

882− Just $ OMathRun style $ Run rstyle relems

771+ return $ OMathRun style $ Run rstyle relems

883−elemToMathElem _ _ = Nothing

772+elemToMathElem _ _ = throwError WrongElem

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

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+

887−elemToParPart :: NameSpaces -> Element -> Maybe ParPart

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 =

793+ let a_ns = "http://schemas.openxmlformats.org/drawingml/2006/main"

794+ drawing = findElement (QName "blip" (Just a_ns) (Just "a")) element

795+ >>= findAttr (QName "embed" (lookup "r" ns) (Just "r"))

796+ in

891− case findChild (QName "drawing" (lookup "w" ns) (Just "w")) element of

797+ case drawing of

892− Just drawingElem -> elemToDrawing ns drawingElem

798+ Just s -> expandDrawingId s

893− Nothing -> do

799+ Nothing -> throwError WrongElem

894− r <- elemToRun ns element

895− return $ PlainRun r

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

908− cAuthor <- findAttr (QName "author" (lookup "w" ns) (Just "w")) element

806+ , Just cAuthor <- findAttr (elemName ns "w" "author") element

909− cDate <- findAttr (QName "date" (lookup "w" ns) (Just "w")) element

807+ , Just cDate <- findAttr (elemName ns "w" "date") element = do

910− let runs = mapMaybe (elemToRun ns) (elChildren element)

808+ runs <- mapD (elemToRun ns) (elChildren element)

911− return $ Deletion cId cAuthor cDate runs

809+ return $ Insertion 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

820+ , Just bmName <- findAttr (elemName ns "w" "name") element =

821+ return $ BookMark bmId bmName

822+elemToParPart ns element

823+ | isElem ns "w" "hyperlink" element

824+ , Just anchor <- findAttr (elemName ns "w" "anchor") element = do

921− let runs = mapMaybe (elemToRun ns)

825+ runs <- mapD (elemToRun ns) (elChildren element)

922− $ findChildren (QName "r" (lookup "w" ns) (Just "w")) element

923− in

924− case findAttr (QName "anchor" (lookup "w" ns) (Just "w")) element of

925− Just anchor ->

926− Just $ InternalHyperLink anchor runs

826+ return $ InternalHyperLink anchor runs

927− Nothing ->

928− case findAttr (QName "id" (lookup "r" ns) (Just "r")) element of

929− Just relId -> Just $ ExternalHyperLink relId runs

930− Nothing -> Nothing

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

832+ return $ case lookupRelationship relId rels of

833+ Just target -> ExternalHyperLink target runs

834+ Nothing -> ExternalHyperLink "" runs

936−elemToParPart _ _ = Nothing

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+