Docx Reader: A nicer Docx type.

This modifies the Docx type in the parser to avoid all the extra files
(Notes, numbering, etc). A reader monad keeps track of these, and applies
them at the end. The reader monad is stacked with ErrorT to enable better
error-handling than the old Maybes. (Note that the better error handling
isn't really there yet, but it is now possible.)

One long-term goal of these changes is to make it easier to write the Docx
type. This should make it easier to develop a standalone docx package in the
future.

2 files changed, 712 insertions, 751 deletions

diff --git a/src/Text/Pandoc/Readers/Docx.hs b/src/Text/Pandoc/Readers/Docx.hs
index 9f73f2e7f..fe4c6b7e6 100644
--- a/src/Text/Pandoc/Readers/Docx.hs
+++ b/src/Text/Pandoc/Readers/Docx.hs
@@ -91,7 +91,6 @@ import Data.List (delete, isPrefixOf, (\\), intercalate)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as B
 import Data.ByteString.Base64 (encode)
-import System.FilePath (combine)
 import qualified Data.Map as M
 import Control.Monad.Reader
 import Control.Monad.State
@@ -102,8 +101,8 @@ readDocx :: ReaderOptions
          -> Pandoc
 readDocx opts bytes =
   case archiveToDocx (toArchive bytes) of
-    Just docx -> Pandoc nullMeta (docxToBlocks opts docx)
-    Nothing   -> error $ "couldn't parse docx file"
+    Right docx -> Pandoc nullMeta (docxToBlocks opts docx)
+    Left _   -> error $ "couldn't parse docx file"
 
 data DState = DState { docxAnchorMap :: M.Map String String
                      , docxInTexSubscript :: Bool }
@@ -159,7 +158,7 @@ runStyleToContainers rPr =
                    , if isStrike rPr then (Just Strikeout) else Nothing
                    , if isSuperScript rPr then (Just Superscript) else Nothing
                    , if isSubScript rPr then (Just Subscript) else Nothing
-                   , underline rPr >>= (\f -> Just $ Span ("", [], [("underline", f)]))
+                   , rUnderline rPr >>= (\f -> Just $ Span ("", [], [("underline", f)]))
                  ]
   in
    classContainers ++ formatters
@@ -259,20 +258,17 @@ runToInlines (Run rs runElems)
   | otherwise =
       return $
       rebuild (runStyleToContainers rs) (concatMap runElemToInlines runElems)
-runToInlines (Footnote fnId) = do
-  (Docx _ notes _ _ _ ) <- asks docxDocument
-  case (getFootNote fnId notes) of
-    Just bodyParts -> do
-      blks <- concatMapM bodyPartToBlocks bodyParts
-      return $ [Note blks]
-    Nothing        -> return [Note []]
-runToInlines (Endnote fnId) = do
-  (Docx _ notes _ _ _ ) <- asks docxDocument
-  case (getEndNote fnId notes) of
-    Just bodyParts -> do
-      blks <- concatMapM bodyPartToBlocks bodyParts
-      return $ [Note blks]
-    Nothing        -> return [Note []]
+runToInlines (Footnote bps) = 
+  concatMapM bodyPartToBlocks bps >>= (\blks -> return [Note blks])
+runToInlines (Endnote bps) = 
+  concatMapM bodyPartToBlocks bps >>= (\blks -> return [Note blks])
+
+makeDataUrl :: String -> B.ByteString -> Maybe String
+makeDataUrl fp bs =
+  case getMimeType fp of
+    Just mime -> Just $ "data:" ++ mime ++ ";base64," ++
+                 toString (encode $ BS.concat $ B.toChunks bs)
+    Nothing   -> Nothing
 
 parPartToInlines :: ParPart -> DocxContext [Inline]
 parPartToInlines (PlainRun r) = runToInlines r
@@ -313,22 +309,18 @@ parPartToInlines (BookMark _ anchor) =
           False -> anchor
     updateDState $ \s -> s { docxAnchorMap = M.insert anchor newAnchor anchorMap}
     return [Span (anchor, ["anchor"], []) []]
-parPartToInlines (Drawing relid) = do
-  (Docx _ _ _ rels _) <- asks docxDocument
-  return $ case lookupRelationship relid rels of
-    Just target -> [Image [] (combine "word" target, "")]
-    Nothing     -> [Image [] ("", "")]
+parPartToInlines (Drawing fp bs) = do
+  return $ case True of                  -- TODO: add self-contained images
+    True -> [Image [] (fp, "")]
+    False -> case makeDataUrl fp bs of
+      Just d -> [Image [] (d, "")]
+      Nothing -> [Image [] ("", "")]
 parPartToInlines (InternalHyperLink anchor runs) = do
   ils <- concatMapM runToInlines runs
   return [Link ils ('#' : anchor, "")]
-parPartToInlines (ExternalHyperLink relid runs) = do
-  (Docx _ _ _ rels _) <- asks docxDocument
-  rs <- concatMapM runToInlines runs
-  return $ case lookupRelationship relid rels of
-    Just target ->
-      [Link rs (target, "")]
-    Nothing ->
-      [Link rs ("", "")]
+parPartToInlines (ExternalHyperLink target runs) = do
+  ils <- concatMapM runToInlines runs
+  return [Link ils (target, "")]
 parPartToInlines (PlainOMath omath) = do
   s <- oMathToTexString omath
   return [Math InlineMath s]
@@ -450,6 +442,9 @@ oMathElemToTexString (NAry _ sub sup base) = do
   baseString <- baseToTexString base
   return $ printf "\\int_{%s}^{%s}{%s}"
     subString supString baseString
+oMathElemToTexString (Phantom base) = do
+  baseString <- baseToTexString base
+  return $ printf "\\phantom{%s}" baseString
 oMathElemToTexString (Radical degree base) = do
   degString  <- concatMapM oMathElemToTexString degree
   baseString <- baseToTexString base
@@ -475,7 +470,6 @@ oMathElemToTexString (Super base sup) = do
   supString  <- concatMapM oMathElemToTexString sup
   return $ printf "%s^{%s}" baseString supString
 oMathElemToTexString (OMathRun _ run) = return $ stringToTex $ runToString run
-oMathElemToTexString _ = return "[NOT IMPLEMENTED]"
 
 baseToTexString :: Base -> DocxContext String
 baseToTexString (Base mathElems) =
@@ -518,9 +512,7 @@ makeHeaderAnchor blk = return blk
 
 parPartsToInlines :: [ParPart] -> DocxContext [Inline]
 parPartsToInlines parparts = do
-  ils <- concatMapM parPartToInlines parparts >>=
-         --  TODO: Option for self-containted images
-         (if False then (walkM makeImagesSelfContained) else return)
+  ils <- concatMapM parPartToInlines parparts
   return $ reduceList $ ils
 
 cellToBlocks :: Cell -> DocxContext [Block]
@@ -563,23 +555,21 @@ bodyPartToBlocks (Paragraph pPr parparts) = do
        rebuild
        (parStyleToContainers pPr)
        [Para ils]
-bodyPartToBlocks (ListItem pPr numId lvl parparts) = do
-  (Docx _ _ numbering _ _) <- asks docxDocument
+bodyPartToBlocks (ListItem pPr numId lvl levelInfo parparts) = do
   let
-    kvs = case lookupLevel numId lvl numbering of
-      Just (_, fmt, txt, Just start) -> [ ("level", lvl)
-                                        , ("num-id", numId)
-                                        , ("format", fmt)
-                                        , ("text", txt)
-                                        , ("start", (show start))
-                                        ]
-
-      Just (_, fmt, txt, Nothing)    -> [ ("level", lvl)
-                                        , ("num-id", numId)
-                                        , ("format", fmt)
-                                        , ("text", txt)
-                                        ]
-      Nothing                        -> []
+    kvs = case levelInfo of
+      (_, fmt, txt, Just start) -> [ ("level", lvl)
+                                   , ("num-id", numId)
+                                   , ("format", fmt)
+                                   , ("text", txt)
+                                   , ("start", (show start))
+                                   ]
+
+      (_, fmt, txt, Nothing)    -> [ ("level", lvl)
+                                   , ("num-id", numId)
+                                   , ("format", fmt)
+                                   , ("text", txt)
+                                   ]
   blks <- bodyPartToBlocks (Paragraph pPr parparts)
   return $ [Div ("", ["list-item"], kvs) blks]
 bodyPartToBlocks (Tbl _ _ _ []) =
@@ -622,20 +612,6 @@ rewriteLink l@(Link ils ('#':target, title)) = do
     Nothing        -> l
 rewriteLink il = return il
 
-makeImagesSelfContained :: Inline -> DocxContext Inline
-makeImagesSelfContained i@(Image alt (uri, title)) = do
-  (Docx _ _ _ _ media) <- asks docxDocument
-  return $ case lookup uri media of
-    Just bs ->
-      case getMimeType uri of
-        Just mime ->
-          let data_uri = "data:" ++ mime ++ ";base64," ++
-                         toString (encode $ BS.concat $ B.toChunks bs)
-          in
-           Image alt (data_uri, title)
-        Nothing  -> i
-    Nothing -> i
-makeImagesSelfContained inline = return inline
 
 bodyToBlocks :: Body -> DocxContext [Block]
 bodyToBlocks (Body bps) = do
@@ -646,7 +622,7 @@ bodyToBlocks (Body bps) = do
     blocksToBullets $ blks
 
 docxToBlocks :: ReaderOptions -> Docx -> [Block]
-docxToBlocks opts d@(Docx (Document _ body) _ _ _ _) =
+docxToBlocks opts d@(Docx (Document _ body)) =
   let dState = DState { docxAnchorMap = M.empty
                       , docxInTexSubscript = False}
       dEnv   = DEnv { docxOptions  = opts
diff --git a/src/Text/Pandoc/Readers/Docx/Parse.hs b/src/Text/Pandoc/Readers/Docx/Parse.hs
index 44585b016..bb65236a3 100644
--- a/src/Text/Pandoc/Readers/Docx/Parse.hs
+++ b/src/Text/Pandoc/Readers/Docx/Parse.hs
@@ -10,59 +10,55 @@ the Free Software Foundation; either version 2 of the License, or
 
 This program is distributed in the hope that it will be useful,
 but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
 GNU General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
 -}
 
 {- |
-   Module      : Text.Pandoc.Readers.Docx.Parse
-   Copyright   : Copyright (C) 2014 Jesse Rosenthal
-   License     : GNU GPL, version 2 or above
+ Module : Text.Pandoc.Readers.Docx.Parse
+ Copyright : Copyright (C) 2014 Jesse Rosenthal
+ License : GNU GPL, version 2 or above
 
-   Maintainer  : Jesse Rosenthal <jrosenthal@jhu.edu>
-   Stability   : alpha
-   Portability : portable
+ Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
+ Stability : alpha
+ Portability : portable
 
 Conversion of docx archive into Docx haskell type
 -}
 
+module Text.Pandoc.Readers.Docx.Parse ( Docx(..)
+                                      , Document(..)
+                                      , Body(..)
+                                      , BodyPart(..)
+                                      , TblLook(..)
+                                      , ParPart(..)
+                                      , OMath(..)
+                                      , OMathElem(..)
+                                      , Base(..)
+                                      , TopBottom(..)
+                                      , AccentStyle(..)
+                                      , BarStyle(..)
+                                      , NAryStyle(..)
+                                      , DelimStyle(..)
+                                      , GroupStyle(..)
+                                      , Run(..)
+                                      , RunElem(..)
+                                      , Notes
+                                      , Numbering
+                                      , Relationship
+                                      , Media
+                                      , RunStyle(..)
+                                      , ParIndentation(..)
+                                      , ParagraphStyle(..)
+                                      , Row(..)
+                                      , Cell(..)
+                                      , archiveToDocx
+                                      ) where
 
-module Text.Pandoc.Readers.Docx.Parse (  Docx(..)
-                                       , Document(..)
-                                       , Body(..)
-                                       , BodyPart(..)
-                                       , TblLook(..)
-                                       , ParPart(..)
-                                       , OMath(..)
-                                       , OMathElem(..)
-                                       , Base(..)
-                                       , TopBottom(..)
-                                       , AccentStyle(..)
-                                       , BarStyle(..)
-                                       , NAryStyle(..)
-                                       , DelimStyle(..)
-                                       , GroupStyle(..)
-                                       , Run(..)
-                                       , RunElem(..)
-                                       , Notes
-                                       , Numbering
-                                       , Relationship
-                                       , Media
-                                       , RunStyle(..)
-                                       , ParIndentation(..)
-                                       , ParagraphStyle(..)
-                                       , Row(..)
-                                       , Cell(..)
-                                       , getFootNote
-                                       , getEndNote
-                                       , lookupLevel
-                                       , lookupRelationship
-                                       , archiveToDocx
-                                       ) where
 import Codec.Archive.Zip
 import Text.XML.Light
 import Data.Maybe
@@ -71,56 +67,53 @@ import System.FilePath
 import Data.Bits ((.|.))
 import qualified Data.ByteString.Lazy as B
 import qualified Text.Pandoc.UTF8 as UTF8
+import Control.Monad.Reader
+import qualified Data.Map as M
+import Control.Monad.Error
+
+data ReaderEnv = ReaderEnv { envNotes         :: Notes
+                           , envNumbering     :: Numbering
+                           , envRelationships :: [Relationship]
+                           , envMedia         :: Media
+                           }
+               deriving Show
 
-attrToNSPair :: Attr -> Maybe (String, String)
-attrToNSPair (Attr (QName s _ (Just "xmlns")) val) = Just (s, val)
-attrToNSPair _ = Nothing
+data DocxError = DocxError | WrongElem
+               deriving Show
+
+instance Error DocxError where
+  noMsg = WrongElem
+
+type D = ErrorT DocxError (Reader ReaderEnv)
+
+runD :: D a -> ReaderEnv -> Either DocxError a
+runD dx re = runReader (runErrorT dx ) re
+
+maybeToD :: Maybe a -> D a
+maybeToD (Just a) = return a
+maybeToD Nothing = throwError DocxError
+
+mapD :: (a -> D b) -> [a] -> D [b]
+mapD _ [] = return []
+mapD f (x:xs) = do
+  y <- (f x >>= (\z -> return [z])) `catchError` (\_ -> return [])
+  ys <- mapD f xs
+  return $ y ++ ys
 
 
 type NameSpaces = [(String, String)]
 
-data Docx = Docx Document Notes Numbering [Relationship] Media
+data Docx = Docx Document
           deriving Show
 
-archiveToDocx :: Archive -> Maybe Docx
-archiveToDocx archive = do
-  let notes = archiveToNotes archive
-      rels = archiveToRelationships archive
-      media = archiveToMedia archive
-  doc <- archiveToDocument archive
-  numbering <- archiveToNumbering archive
-  return $ Docx doc notes numbering rels media
-
 data Document = Document NameSpaces Body 
           deriving Show
 
-archiveToDocument :: Archive -> Maybe Document
-archiveToDocument zf = do
-  entry <- findEntryByPath "word/document.xml" zf
-  docElem <- (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry
-  let namespaces = mapMaybe attrToNSPair (elAttribs docElem) 
-  bodyElem <- findChild (QName "body" (lookup "w" namespaces) Nothing) docElem
-  body <- elemToBody namespaces bodyElem
-  return $ Document namespaces body
+data Body = Body [BodyPart]
+          deriving Show
 
 type Media = [(FilePath, B.ByteString)]
 
-filePathIsMedia :: FilePath -> Bool
-filePathIsMedia fp =
-  let (dir, _) = splitFileName fp
-  in
-   (dir == "word/media/")
-
-getMediaPair :: Archive -> FilePath -> Maybe (FilePath, B.ByteString)
-getMediaPair zf fp =
-  case findEntryByPath fp zf of
-    Just e -> Just (fp, fromEntry e)
-    Nothing -> Nothing
-
-archiveToMedia :: Archive -> Media
-archiveToMedia zf =
-  mapMaybe (getMediaPair zf) (filter filePathIsMedia (filesInArchive zf))
-
 data Numbering = Numbering NameSpaces [Numb] [AbstractNumb]
                  deriving Show
 
@@ -133,240 +126,12 @@ data AbstractNumb = AbstractNumb String [Level]
 -- (ilvl, format, string, start)
 type Level = (String, String, String, Maybe Integer)
 
-lookupLevel :: String -> String -> Numbering -> Maybe Level
-lookupLevel numId ilvl (Numbering _ numbs absNumbs) = do
-  absNumId <- lookup numId $ map (\(Numb nid absnumid) -> (nid, absnumid)) numbs
-  lvls <- lookup absNumId $ map (\(AbstractNumb aid ls) -> (aid, ls)) absNumbs
-  lvl  <- lookup ilvl $ map (\l@(i, _, _, _) -> (i, l)) lvls
-  return lvl
-
-numElemToNum :: NameSpaces -> Element -> Maybe Numb
-numElemToNum ns element |
-  qName (elName element) == "num" &&
-  qURI (elName element) == (lookup "w" ns) = do
-    numId <- findAttr (QName "numId" (lookup "w" ns) (Just "w")) element
-    absNumId <- findChild (QName "abstractNumId" (lookup "w" ns) (Just "w")) element
-                >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
-    return $ Numb numId absNumId
-numElemToNum _ _ = Nothing
-
-absNumElemToAbsNum :: NameSpaces -> Element -> Maybe AbstractNumb
-absNumElemToAbsNum ns element |
-  qName (elName element) == "abstractNum" &&
-  qURI (elName element) == (lookup "w" ns) = do
-    absNumId <- findAttr
-                (QName "abstractNumId" (lookup "w" ns) (Just "w"))
-                element
-    let levelElems = findChildren
-                 (QName "lvl" (lookup "w" ns) (Just "w"))
-                 element
-        levels = mapMaybe (levelElemToLevel ns) levelElems
-    return $ AbstractNumb absNumId levels
-absNumElemToAbsNum _ _ = Nothing
-
-levelElemToLevel :: NameSpaces -> Element -> Maybe Level
-levelElemToLevel ns element |
-    qName (elName element) == "lvl" &&
-    qURI (elName element) == (lookup "w" ns) = do
-      ilvl <- findAttr (QName "ilvl" (lookup "w" ns) (Just "w")) element
-      fmt <- findChild (QName "numFmt" (lookup "w" ns) (Just "w")) element
-             >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
-      txt <- findChild (QName "lvlText" (lookup "w" ns) (Just "w")) element
-             >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
-      let start = findChild (QName "start" (lookup "w" ns) (Just "w")) element
-                  >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
-                  >>= (\s -> listToMaybe (map fst (reads s :: [(Integer, String)])))
-      return (ilvl, fmt, txt, start)
-levelElemToLevel _ _ = Nothing
-
-archiveToNumbering :: Archive -> Maybe Numbering
-archiveToNumbering zf =
-  case findEntryByPath "word/numbering.xml" zf of
-    Nothing -> Just $ Numbering [] [] []
-    Just entry -> do
-      numberingElem <- (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry
-      let namespaces = mapMaybe attrToNSPair (elAttribs numberingElem)
-          numElems = findChildren
-                     (QName "num" (lookup "w" namespaces) (Just "w"))
-                     numberingElem
-          absNumElems = findChildren
-                        (QName "abstractNum" (lookup "w" namespaces) (Just "w"))
-                        numberingElem
-          nums = mapMaybe (numElemToNum namespaces) numElems
-          absNums = mapMaybe (absNumElemToAbsNum namespaces) absNumElems
-      return $ Numbering namespaces nums absNums
-
-data Notes = Notes NameSpaces (Maybe [(String, [BodyPart])]) (Maybe [(String, [BodyPart])])
-           deriving Show
-
-noteElemToNote :: NameSpaces -> Element -> Maybe (String, [BodyPart])
-noteElemToNote ns element
-  | qName (elName element) `elem` ["endnote", "footnote"] &&
-    qURI (elName element) == (lookup "w" ns) =
-      do
-        noteId <- findAttr (QName "id" (lookup "w" ns) (Just "w")) element
-        let bps = mapMaybe  (elemToBodyPart ns)
-                  $ elChildren element
-        return $ (noteId, bps)
-noteElemToNote _ _ = Nothing
-
-getFootNote :: String -> Notes -> Maybe [BodyPart]
-getFootNote s (Notes _ fns _) = fns >>= (lookup s)
-
-getEndNote :: String -> Notes -> Maybe [BodyPart]
-getEndNote s (Notes _ _ ens) = ens >>= (lookup s)
-
-elemToNotes :: NameSpaces -> String -> Element -> Maybe [(String, [BodyPart])]
-elemToNotes ns notetype element
-  | qName (elName element) == (notetype ++ "s") &&
-    qURI (elName element) == (lookup "w" ns) =
-      Just $ mapMaybe (noteElemToNote ns)
-      $ findChildren (QName notetype (lookup "w" ns) (Just "w")) element
-elemToNotes _ _ _ = Nothing
-
-archiveToNotes :: Archive -> Notes
-archiveToNotes zf =
-  let fnElem = findEntryByPath "word/footnotes.xml" zf
-               >>= (parseXMLDoc . UTF8.toStringLazy . fromEntry)
-      enElem = findEntryByPath "word/endnotes.xml" zf
-               >>= (parseXMLDoc . UTF8.toStringLazy . fromEntry)
-      fn_namespaces = case fnElem of
-        Just e -> mapMaybe attrToNSPair (elAttribs e)
-        Nothing -> []
-      en_namespaces = case enElem of
-        Just e -> mapMaybe attrToNSPair (elAttribs e)
-        Nothing -> []
-      ns = unionBy (\x y -> fst x == fst y) fn_namespaces en_namespaces
-      fn = fnElem >>= (elemToNotes ns "footnote")
-      en = enElem >>= (elemToNotes ns "endnote")
-  in
-   Notes ns fn en
-
-
 data Relationship = Relationship (RelId, Target)
                   deriving Show
-
-lookupRelationship :: RelId -> [Relationship] -> Maybe Target
-lookupRelationship relid rels =
-  lookup relid (map (\(Relationship pair) -> pair) rels)
-
-filePathIsRel :: FilePath -> Bool
-filePathIsRel fp =
-  let (dir, name) = splitFileName fp
-  in
-   (dir == "word/_rels/") && ((takeExtension name) == ".rels")
-
-relElemToRelationship :: Element -> Maybe Relationship
-relElemToRelationship element | qName (elName element) == "Relationship" =
-  do
-    relId <- findAttr (QName "Id" Nothing Nothing) element
-    target <- findAttr (QName "Target" Nothing Nothing) element
-    return $ Relationship (relId, target)
-relElemToRelationship _ = Nothing
-  
-
-archiveToRelationships :: Archive -> [Relationship]
-archiveToRelationships archive = 
-  let relPaths = filter filePathIsRel (filesInArchive archive)
-      entries  = mapMaybe (\f -> findEntryByPath f archive) relPaths
-      relElems = mapMaybe (parseXMLDoc . UTF8.toStringLazy . fromEntry) entries
-      rels =     mapMaybe relElemToRelationship $ concatMap elChildren relElems
-  in
-   rels
-   
-data Body = Body [BodyPart]
-          deriving Show
-
-elemToBody :: NameSpaces -> Element ->  Maybe Body
-elemToBody ns element | qName (elName element) == "body" && qURI (elName element) == (lookup "w" ns) =
-  Just $ Body
-  $ mapMaybe (elemToBodyPart ns) $ elChildren element
-elemToBody _ _ = Nothing
-
-elemToNumInfo :: NameSpaces -> Element -> Maybe (String, String)
-elemToNumInfo ns element
-  | qName (elName element) == "p" &&
-    qURI (elName element) == (lookup "w" ns) =
-      do
-        pPr <- findChild (QName "pPr" (lookup "w" ns) (Just "w")) element
-        numPr <- findChild (QName "numPr" (lookup "w" ns) (Just "w")) pPr
-        lvl <- findChild (QName "ilvl" (lookup "w" ns) (Just "w")) numPr >>=
-                findAttr (QName "val" (lookup "w" ns) (Just "w"))
-        numId <- findChild (QName "numId" (lookup "w" ns) (Just "w")) numPr >>=
-                 findAttr (QName "val" (lookup "w" ns) (Just "w"))
-        return (numId, lvl)
-elemToNumInfo _ _ = Nothing
-
-elemToBodyPart :: NameSpaces -> Element ->  Maybe BodyPart
-elemToBodyPart ns element
-  | qName (elName element) == "p" &&
-    qURI (elName element) == (lookup "w" ns)
-  , (c:_) <- findChildren (QName "oMathPara" (lookup "m" ns) (Just "m")) element =
-      let style = []  -- placeholder
-          maths = mapMaybe (elemToMath ns)
-                  $ findChildren
-                  (QName "oMath" (lookup "m" ns) (Just "m")) c
-      in
-       Just $ OMathPara style maths
-  | qName (elName element) == "p" &&
-    qURI (elName element) == (lookup "w" ns)
-  , Just (numId, lvl) <- elemToNumInfo ns element =
-      let parstyle = elemToParagraphStyle ns element
-          parparts = mapMaybe (elemToParPart ns)
-                     $ elChildren element
-      in
-       Just $ ListItem parstyle numId lvl parparts
-  | qName (elName element) == "p" &&
-    qURI (elName element) == (lookup "w" ns) =
-      let parstyle = elemToParagraphStyle ns element
-          parparts = mapMaybe (elemToParPart ns)
-                     $ elChildren element
-      in
-       Just $ Paragraph parstyle parparts
-  | qName (elName element) == "tbl" &&
-    qURI (elName element) == (lookup "w" ns) =
-      let
-        caption = findChild (QName "tblPr" (lookup "w" ns) (Just "w")) element
-                  >>= findChild (QName "tblCaption" (lookup "w" ns) (Just "w"))
-                  >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
-        grid = case
-          findChild (QName "tblGrid" (lookup "w" ns) (Just "w")) element
-          of
-            Just g -> elemToTblGrid ns g
-            Nothing -> []
-        tblLook = findChild (QName "tblPr" (lookup "w" ns) (Just "w")) element
-                  >>= findChild (QName "tblLook" (lookup "w" ns) (Just "w"))
-                  >>= elemToTblLook ns
-      in
-       Just $ Tbl
-       (fromMaybe "" caption)
-       grid
-       (fromMaybe defaultTblLook tblLook)
-       (mapMaybe (elemToRow ns) (elChildren element))
-  | otherwise = Nothing
-
-elemToTblLook :: NameSpaces -> Element -> Maybe TblLook
-elemToTblLook ns element
-  | qName (elName element) == "tblLook" &&
-    qURI (elName element) == (lookup "w" ns) =
-      let firstRow = findAttr (QName "firstRow" (lookup "w" ns) (Just "w")) element
-          val = findAttr (QName "val" (lookup "w" ns) (Just "w")) element
-          firstRowFmt = 
-            case firstRow of
-              Just "1" -> True
-              Just  _  -> False
-              Nothing -> case val of
-                Just bitMask -> testBitMask bitMask 0x020
-                Nothing      -> False
-      in
-       Just $ TblLook{firstRowFormatting = firstRowFmt}
-elemToTblLook _ _ = Nothing
-
-testBitMask :: String -> Int -> Bool
-testBitMask bitMaskS n =
-  case (reads ("0x" ++ bitMaskS) :: [(Int, String)]) of
-    []            -> False
-    ((n', _) : _) -> ((n' .|. n) /= 0)
+data Notes = Notes NameSpaces
+             (Maybe (M.Map String Element))
+             (Maybe (M.Map String Element))
+           deriving Show
 
 data ParIndentation = ParIndentation { leftParIndent :: Maybe Integer
                                      , rightParIndent :: Maybe Integer
@@ -383,40 +148,9 @@ defaultParagraphStyle = ParagraphStyle { pStyle = []
                                        , indentation = Nothing
                                        }
 
-elemToParIndentation :: NameSpaces -> Element -> Maybe ParIndentation
-elemToParIndentation ns element
-  | qName (elName element) == "ind" &&
-    qURI (elName element) == (lookup "w" ns) =
-      Just $ ParIndentation {
-        leftParIndent =
-           findAttr (QName "left" (lookup "w" ns) (Just "w")) element >>=
-           stringToInteger
-        , rightParIndent = 
-          findAttr (QName "right" (lookup "w" ns) (Just "w")) element >>=
-          stringToInteger
-        , hangingParIndent = 
-          findAttr (QName "hanging" (lookup "w" ns) (Just "w")) element >>=
-          stringToInteger}
-elemToParIndentation _ _ = Nothing
-
-elemToParagraphStyle :: NameSpaces -> Element -> ParagraphStyle
-elemToParagraphStyle ns element =
-  case findChild (QName "pPr" (lookup "w" ns) (Just "w")) element of
-    Just pPr ->
-      ParagraphStyle
-      {pStyle =
-          mapMaybe
-          (findAttr (QName "val" (lookup "w" ns) (Just "w")))
-          (findChildren (QName "pStyle" (lookup "w" ns) (Just "w")) pPr)
-      , indentation =
-        findChild (QName "ind" (lookup "w" ns) (Just "w")) pPr >>=
-        elemToParIndentation ns
-        }
-    Nothing -> defaultParagraphStyle
-
 
 data BodyPart = Paragraph ParagraphStyle [ParPart]
-              | ListItem ParagraphStyle String String [ParPart]
+              | ListItem ParagraphStyle String String Level [ParPart]
               | Tbl String TblGrid TblLook [Row]
               | OMathPara OMathParaStyle [OMath]
               deriving Show
@@ -429,62 +163,22 @@ data TblLook = TblLook {firstRowFormatting::Bool}
 defaultTblLook :: TblLook
 defaultTblLook = TblLook{firstRowFormatting = False}
 
-stringToInteger :: String -> Maybe Integer
-stringToInteger s = listToMaybe $ map fst (reads s :: [(Integer, String)])
-
-elemToTblGrid :: NameSpaces -> Element -> TblGrid
-elemToTblGrid ns element
-  | qName (elName element) == "tblGrid" &&
-    qURI (elName element) == (lookup "w" ns) =
-      let
-        cols = findChildren (QName "gridCol" (lookup "w" ns) (Just "w")) element
-      in
-       mapMaybe (\e ->
-                  findAttr (QName "val" (lookup "w" ns) (Just ("w"))) e
-                  >>= stringToInteger
-                )
-       cols
-elemToTblGrid _ _ = []
-
 data Row = Row [Cell]
            deriving Show
 
-
-elemToRow :: NameSpaces -> Element -> Maybe Row
-elemToRow ns element
-  | qName (elName element) == "tr" &&
-    qURI (elName element) == (lookup "w" ns) =
-      let 
-        cells = findChildren (QName "tc" (lookup "w" ns) (Just "w")) element
-      in
-       Just $ Row (mapMaybe (elemToCell ns) cells)
-elemToRow _ _ = Nothing
-
 data Cell = Cell [BodyPart]
             deriving Show
 
-elemToCell :: NameSpaces -> Element -> Maybe Cell
-elemToCell ns element
-  | qName (elName element) == "tc" &&
-    qURI (elName element) == (lookup "w" ns) =
-      Just $ Cell (mapMaybe (elemToBodyPart ns) (elChildren element))
-elemToCell _ _ = Nothing
-
 data ParPart = PlainRun Run
              | Insertion ChangeId Author ChangeDate [Run]
              | Deletion ChangeId Author ChangeDate [Run]
              | BookMark BookMarkId Anchor
              | InternalHyperLink Anchor [Run]
-             | ExternalHyperLink RelId [Run]
-             | Drawing String
+             | ExternalHyperLink URL [Run]
+             | Drawing FilePath B.ByteString
              | PlainOMath OMath
              deriving Show
 
-data Run = Run RunStyle [RunElem]
-         | Footnote String 
-         | Endnote String
-           deriving Show
-
 data OMath = OMath [OMathElem]
           deriving Show
 
@@ -554,6 +248,12 @@ defaultGroupStyle = GroupStyle {groupChr = Nothing, groupPos = Nothing}
 
 type OMathRunStyle = [String]
 
+
+data Run = Run RunStyle [RunElem]
+         | Footnote [BodyPart]
+         | Endnote [BodyPart]
+           deriving Show
+
 data RunElem = TextRun String | LnBrk | Tab
              deriving Show
 
@@ -563,7 +263,7 @@ data RunStyle = RunStyle { isBold :: Bool
                          , isStrike :: Bool
                          , isSuperScript :: Bool
                          , isSubScript :: Bool
-                         , underline :: Maybe String
+                         , rUnderline :: Maybe String
                          , rStyle :: Maybe String }
                 deriving Show
 
@@ -574,104 +274,327 @@ defaultRunStyle = RunStyle { isBold = False
                            , isStrike = False
                            , isSuperScript = False
                            , isSubScript = False
-                           , underline = Nothing
+                           , rUnderline = Nothing
                            , rStyle = Nothing
                            } 
 
-elemToRunStyle :: NameSpaces -> Element -> RunStyle
-elemToRunStyle ns element =
-  case findChild (QName "rPr" (lookup "w" ns) (Just "w")) element of
-    Just rPr ->
-      RunStyle
-      {
-        isBold = isJust $ findChild (QName "b" (lookup "w" ns) (Just "w")) rPr
-      , isItalic = isJust $ findChild (QName "i" (lookup "w" ns) (Just "w")) rPr
-      , isSmallCaps = isJust $ findChild (QName "smallCaps" (lookup "w" ns) (Just "w")) rPr
-      , isStrike = isJust $ findChild (QName "strike" (lookup "w" ns) (Just "w")) rPr
-      , isSuperScript =
-        (Just "superscript" ==
-        (findChild (QName "vertAlign" (lookup "w" ns) (Just "w")) rPr >>=
-         findAttr (QName "val" (lookup "w" ns) (Just "w"))))
-      , isSubScript =
-        (Just "subscript" ==
-        (findChild (QName "vertAlign" (lookup "w" ns) (Just "w")) rPr >>=
-         findAttr (QName "val" (lookup "w" ns) (Just "w"))))
-      , underline =
-        findChild (QName "u" (lookup "w" ns) (Just "w")) rPr >>=
-        findAttr (QName "val" (lookup "w" ns) (Just "w"))
-      , rStyle =
-        findChild (QName "rStyle" (lookup "w" ns) (Just "w")) rPr >>=
-        findAttr (QName "val" (lookup "w" ns) (Just "w"))
-        }
-    Nothing -> defaultRunStyle
 
-elemToRun :: NameSpaces -> Element -> Maybe Run
-elemToRun ns element
-  | qName (elName element) == "r" &&
-    qURI (elName element) == (lookup "w" ns) =
-      case
-        findChild (QName "footnoteReference" (lookup "w" ns) (Just "w")) element >>=
-        findAttr (QName "id" (lookup "w" ns) (Just "w"))
-      of
-        Just s -> Just $ Footnote s
-        Nothing ->
-          case
-            findChild (QName "endnoteReference" (lookup "w" ns) (Just "w")) element >>=
-            findAttr (QName "id" (lookup "w" ns) (Just "w"))
-          of
-            Just s -> Just $ Endnote s 
-            Nothing ->  Just $
-                        Run (elemToRunStyle ns element)
-                        (elemToRunElems ns element)
-elemToRun _ _ = Nothing
-
-elemToRunElem :: NameSpaces -> Element -> Maybe RunElem
-elemToRunElem ns element
-  | (qName (elName element) == "t" || qName (elName element) == "delText") &&
-    qURI (elName element) `elem` [(lookup "w" ns), (lookup "m" ns)] =
-      Just $ TextRun (strContent element)
-  | qName (elName element) == "br" &&
-    qURI (elName element) `elem` [(lookup "w" ns), (lookup "m" ns)] =
-      Just $ LnBrk
-  | qName (elName element) == "tab" &&
-    qURI (elName element) `elem` [(lookup "w" ns), (lookup "m" ns)] =
-      Just $ Tab
-  | otherwise = Nothing
-
-
-elemToRunElems :: NameSpaces -> Element -> [RunElem]
-elemToRunElems ns element
-  | qName (elName element) == "r" &&
-    qURI (elName element) `elem` [(lookup "w" ns), (lookup "m" ns)] =
-      mapMaybe (elemToRunElem ns) (elChildren element)
-  | otherwise = []
-
-elemToDrawing :: NameSpaces -> Element -> Maybe ParPart
-elemToDrawing ns element
-  | qName (elName element) == "drawing" &&
-    qURI (elName element) == (lookup "w" ns) =
-      let a_ns = "http://schemas.openxmlformats.org/drawingml/2006/main"
+type Target = String
+type Anchor = String
+type URL = String
+type BookMarkId = String
+type RelId = String
+type ChangeId = String
+type Author = String
+type ChangeDate = String               
+
+attrToNSPair :: Attr -> Maybe (String, String)
+attrToNSPair (Attr (QName s _ (Just "xmlns")) val) = Just (s, val)
+attrToNSPair _ = Nothing
+
+archiveToDocx :: Archive -> Either DocxError Docx
+archiveToDocx archive = do
+  let notes     = archiveToNotes archive
+      numbering = archiveToNumbering archive
+      rels      = archiveToRelationships archive
+      media     = archiveToMedia archive
+      rEnv = ReaderEnv notes numbering rels media
+  doc <- runD (archiveToDocument archive) rEnv
+  return $ Docx doc
+    
+
+archiveToDocument :: Archive -> D Document
+archiveToDocument zf = do
+  entry <- maybeToD $ findEntryByPath "word/document.xml" zf
+  docElem <- maybeToD $ (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry
+  let namespaces = mapMaybe attrToNSPair (elAttribs docElem) 
+  bodyElem <- maybeToD $ findChild (elemName namespaces "w" "body") docElem
+  body <- elemToBody namespaces bodyElem
+  return $ Document namespaces body
+
+elemToBody :: NameSpaces -> Element -> D Body 
+elemToBody ns element | isElem ns "w" "body" element =
+  mapD (elemToBodyPart ns) (elChildren element) >>=
+  (\bps -> return $ Body bps)
+elemToBody _ _ = throwError WrongElem
+
+archiveToNotes :: Archive -> Notes
+archiveToNotes zf =
+  let fnElem = findEntryByPath "word/footnotes.xml" zf
+               >>= (parseXMLDoc . UTF8.toStringLazy . fromEntry)
+      enElem = findEntryByPath "word/endnotes.xml" zf
+               >>= (parseXMLDoc . UTF8.toStringLazy . fromEntry)
+      fn_namespaces = case fnElem of
+        Just e -> mapMaybe attrToNSPair (elAttribs e)
+        Nothing -> []
+      en_namespaces = case enElem of
+        Just e -> mapMaybe attrToNSPair (elAttribs e)
+        Nothing -> []
+      ns = unionBy (\x y -> fst x == fst y) fn_namespaces en_namespaces
+      fn = fnElem >>= (elemToNotes ns "footnote")
+      en = enElem >>= (elemToNotes ns "endnote")
+  in
+   Notes ns fn en
+
+filePathIsRel :: FilePath -> Bool
+filePathIsRel fp =
+  let (dir, name) = splitFileName fp
+  in
+   (dir == "word/_rels/") && ((takeExtension name) == ".rels")
+
+relElemToRelationship :: Element -> Maybe Relationship
+relElemToRelationship element | qName (elName element) == "Relationship" =
+  do
+    relId <- findAttr (QName "Id" Nothing Nothing) element
+    target <- findAttr (QName "Target" Nothing Nothing) element
+    return $ Relationship (relId, target)
+relElemToRelationship _ = Nothing
+  
+
+archiveToRelationships :: Archive -> [Relationship]
+archiveToRelationships archive = 
+  let relPaths = filter filePathIsRel (filesInArchive archive)
+      entries  = mapMaybe (\f -> findEntryByPath f archive) relPaths
+      relElems = mapMaybe (parseXMLDoc . UTF8.toStringLazy . fromEntry) entries
+      rels =     mapMaybe relElemToRelationship $ concatMap elChildren relElems
+  in
+   rels
+
+filePathIsMedia :: FilePath -> Bool
+filePathIsMedia fp =
+  let (dir, _) = splitFileName fp
+  in
+   (dir == "word/media/")
+
+getMediaPair :: Archive -> FilePath -> Maybe (FilePath, B.ByteString)
+getMediaPair zf fp =
+  case findEntryByPath fp zf of
+    Just e -> Just (fp, fromEntry e)
+    Nothing -> Nothing
+
+archiveToMedia :: Archive -> Media
+archiveToMedia zf =
+  mapMaybe (getMediaPair zf) (filter filePathIsMedia (filesInArchive zf))
+
+lookupLevel :: String -> String -> Numbering -> Maybe Level
+lookupLevel numId ilvl (Numbering _ numbs absNumbs) = do
+  absNumId <- lookup numId $ map (\(Numb nid absnumid) -> (nid, absnumid)) numbs
+  lvls <- lookup absNumId $ map (\(AbstractNumb aid ls) -> (aid, ls)) absNumbs
+  lvl  <- lookup ilvl $ map (\l@(i, _, _, _) -> (i, l)) lvls
+  return lvl
+
+numElemToNum :: NameSpaces -> Element -> Maybe Numb
+numElemToNum ns element |
+  qName (elName element) == "num" &&
+  qURI (elName element) == (lookup "w" ns) = do
+    numId <- findAttr (QName "numId" (lookup "w" ns) (Just "w")) element
+    absNumId <- findChild (QName "abstractNumId" (lookup "w" ns) (Just "w")) element
+                >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
+    return $ Numb numId absNumId
+numElemToNum _ _ = Nothing
+
+absNumElemToAbsNum :: NameSpaces -> Element -> Maybe AbstractNumb
+absNumElemToAbsNum ns element |
+  qName (elName element) == "abstractNum" &&
+  qURI (elName element) == (lookup "w" ns) = do
+    absNumId <- findAttr
+                (QName "abstractNumId" (lookup "w" ns) (Just "w"))
+                element
+    let levelElems = findChildren
+                 (QName "lvl" (lookup "w" ns) (Just "w"))
+                 element
+        levels = mapMaybe (levelElemToLevel ns) levelElems
+    return $ AbstractNumb absNumId levels
+absNumElemToAbsNum _ _ = Nothing
+
+levelElemToLevel :: NameSpaces -> Element -> Maybe Level
+levelElemToLevel ns element |
+    qName (elName element) == "lvl" &&
+    qURI (elName element) == (lookup "w" ns) = do
+      ilvl <- findAttr (QName "ilvl" (lookup "w" ns) (Just "w")) element
+      fmt <- findChild (QName "numFmt" (lookup "w" ns) (Just "w")) element
+             >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
+      txt <- findChild (QName "lvlText" (lookup "w" ns) (Just "w")) element
+             >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
+      let start = findChild (QName "start" (lookup "w" ns) (Just "w")) element
+                  >>= findAttr (QName "val" (lookup "w" ns) (Just "w"))
+                  >>= (\s -> listToMaybe (map fst (reads s :: [(Integer, String)])))
+      return (ilvl, fmt, txt, start)
+levelElemToLevel _ _ = Nothing
+
+archiveToNumbering' :: Archive -> Maybe Numbering
+archiveToNumbering' zf = do
+  case findEntryByPath "word/numbering.xml" zf of
+    Nothing -> Just $ Numbering [] [] []
+    Just entry -> do
+      numberingElem <- (parseXMLDoc . UTF8.toStringLazy . fromEntry) entry
+      let namespaces = mapMaybe attrToNSPair (elAttribs numberingElem)
+          numElems = findChildren
+                     (QName "num" (lookup "w" namespaces) (Just "w"))
+                     numberingElem
+          absNumElems = findChildren
+                        (QName "abstractNum" (lookup "w" namespaces) (Just "w"))
+                        numberingElem
+          nums = mapMaybe (numElemToNum namespaces) numElems
+          absNums = mapMaybe (absNumElemToAbsNum namespaces) absNumElems
+      return $ Numbering namespaces nums absNums
+
+archiveToNumbering :: Archive -> Numbering
+archiveToNumbering archive =
+  fromMaybe (Numbering [] [] []) (archiveToNumbering' archive)
+
+elemToNotes :: NameSpaces -> String -> Element -> Maybe (M.Map String Element)
+elemToNotes ns notetype element
+  | isElem ns "w" (notetype ++ "s") element = 
+      let pairs = mapMaybe
+                  (\e -> findAttr (elemName ns "w" "id") e >>=
+                         (\a -> Just (a, e)))
+                  (findChildren (elemName ns "w" notetype) element)
       in
-       findElement (QName "blip" (Just a_ns) (Just "a")) element
-       >>= findAttr (QName "embed" (lookup "r" ns) (Just "r"))
-       >>= (\s -> Just $ Drawing s)
-elemToDrawing _ _ = Nothing
+       Just $ M.fromList $ pairs
+elemToNotes _ _ _ = Nothing
 
-elemToMath :: NameSpaces -> Element -> Maybe OMath
-elemToMath ns element 
-  | qName (elName element) == "oMath" &&
-    qURI (elName element) == (lookup "m" ns) =
-      Just $ OMath $ mapMaybe (elemToMathElem ns) (elChildren element)
-elemToMath _ _ = Nothing
+---------------------------------------------
+---------------------------------------------
 
+elemName :: NameSpaces -> String -> String -> QName
+elemName ns prefix name = (QName name (lookup prefix ns) (Just prefix))
 
+isElem :: NameSpaces -> String -> String -> Element -> Bool
+isElem ns prefix name element =
+  qName (elName element) == name &&
+  qURI (elName element) == (lookup prefix ns)
 
-elemToBase :: NameSpaces -> Element -> Maybe Base
-elemToBase ns element 
-  | qName (elName element) == "e" &&
-    qURI (elName element) == (lookup "m" ns) =
-      Just $ Base $ mapMaybe (elemToMathElem ns) (elChildren element)
-elemToBase _ _ = Nothing
+
+elemToTblGrid :: NameSpaces -> Element -> D TblGrid
+elemToTblGrid ns element | isElem ns "w" "tblGrid" element =
+  let cols = findChildren (elemName ns "w" "gridCol") element
+  in
+   mapD (\e -> maybeToD (findAttr (elemName ns "w" "val") e >>= stringToInteger))
+   cols
+elemToTblGrid _ _ = throwError WrongElem
+
+elemToTblLook :: NameSpaces -> Element -> D TblLook
+elemToTblLook ns element | isElem ns "w" "tblLook" element =
+  let firstRow = findAttr (elemName ns "w" "firstRow") element
+      val = findAttr (elemName ns "w" "val") element
+      firstRowFmt = 
+        case firstRow of
+          Just "1" -> True
+          Just  _  -> False
+          Nothing -> case val of
+            Just bitMask -> testBitMask bitMask 0x020
+            Nothing      -> False
+  in
+   return $ TblLook{firstRowFormatting = firstRowFmt}
+elemToTblLook _ _ = throwError WrongElem
+
+elemToRow :: NameSpaces -> Element -> D Row
+elemToRow ns element | isElem ns "w" "tr" element =
+  do
+    let cellElems = findChildren (elemName ns "w" "tc") element
+    cells <- mapD (elemToCell ns) cellElems
+    return $ Row cells
+elemToRow _ _ = throwError WrongElem
+
+elemToCell :: NameSpaces -> Element -> D Cell
+elemToCell ns element | isElem ns "w" "tc" element =
+  do
+    cellContents <- mapD (elemToBodyPart ns) (elChildren element)
+    return $ Cell cellContents
+elemToCell _ _ = throwError WrongElem
+
+elemToParIndentation :: NameSpaces -> Element -> Maybe ParIndentation
+elemToParIndentation ns element | isElem ns "w" "ind" element = 
+  Just $ ParIndentation {
+    leftParIndent =
+       findAttr (QName "left" (lookup "w" ns) (Just "w")) element >>=
+       stringToInteger
+    , rightParIndent = 
+      findAttr (QName "right" (lookup "w" ns) (Just "w")) element >>=
+      stringToInteger
+    , hangingParIndent = 
+      findAttr (QName "hanging" (lookup "w" ns) (Just "w")) element >>=
+      stringToInteger}
+elemToParIndentation _ _ = Nothing
+
+
+elemToNumInfo :: NameSpaces -> Element -> Maybe (String, String)
+elemToNumInfo ns element  | isElem ns "w" "p" element = do
+  let pPr = findChild (elemName ns "w" "pPr") element
+      numPr = pPr >>= findChild (elemName ns "w" "numPr")
+  lvl <- numPr >>=
+         findChild (elemName ns "w" "ilvl") >>=
+         findAttr (elemName ns "w" "val")
+  numId <- numPr >>=
+           findChild (elemName ns "w" "numId") >>=
+           findAttr (elemName ns "w" "val")
+  return (numId, lvl)
+elemToNumInfo _ _ = Nothing
+
+testBitMask :: String -> Int -> Bool
+testBitMask bitMaskS n =
+  case (reads ("0x" ++ bitMaskS) :: [(Int, String)]) of
+    []            -> False
+    ((n', _) : _) -> ((n' .|. n) /= 0)
+
+stringToInteger :: String -> Maybe Integer
+stringToInteger s = listToMaybe $ map fst (reads s :: [(Integer, String)])
+
+elemToBodyPart :: NameSpaces -> Element -> D BodyPart
+elemToBodyPart ns element
+  | isElem ns "w" "p" element
+  , (c:_) <- findChildren (elemName ns "m" "oMathPara") element =
+      do
+        let style = []  -- placeholder
+        maths <- mapD (elemToMath ns) (elChildren c)
+        return $ OMathPara style maths
+elemToBodyPart ns element
+  | isElem ns "w" "p" element
+  , Just (numId, lvl) <- elemToNumInfo ns element = do
+    let parstyle = elemToParagraphStyle ns element
+    parparts <- mapD (elemToParPart ns) (elChildren element)
+    num <- asks envNumbering
+    case lookupLevel numId lvl num of
+      Just levelInfo -> return $ ListItem parstyle numId lvl levelInfo parparts
+      Nothing         -> throwError WrongElem
+elemToBodyPart ns element 
+  | isElem ns "w" "p" element = do
+    let parstyle = elemToParagraphStyle ns element
+    parparts <- mapD (elemToParPart ns) (elChildren element)
+    return $ Paragraph parstyle parparts
+elemToBodyPart ns element
+  | isElem ns "w" "tbl" element = do
+    let caption' = findChild (elemName ns "w" "tblPr") element
+                   >>= findChild (elemName ns "w" "tblCaption")
+                   >>= findAttr (elemName ns "w" "val")
+        caption = (fromMaybe "" caption')
+        grid' = case findChild (elemName ns "w" "tblGrid") element of
+          Just g -> elemToTblGrid ns g
+          Nothing -> return []
+        tblLook' = case findChild (elemName ns "w" "tblPr") element >>=
+                          findChild (elemName ns "w" "tblLook")
+                     of
+                       Just l -> elemToTblLook ns l
+                       Nothing -> return defaultTblLook
+
+    grid <- grid'
+    tblLook <- tblLook'
+    rows <- mapD (elemToRow ns) (elChildren element)
+    return $ Tbl caption grid tblLook rows
+elemToBodyPart _ _ = throwError WrongElem
+
+elemToMath :: NameSpaces -> Element -> D OMath
+elemToMath ns element  | isElem ns "m" "oMath" element =
+    mapD (elemToMathElem ns) (elChildren element) >>=
+    (\es -> return $ OMath es)
+elemToMath _ _ = throwError WrongElem
+
+elemToBase :: NameSpaces -> Element -> D Base
+elemToBase ns element | isElem ns "m" "e" element =
+  mapD (elemToMathElem ns) (elChildren element) >>=
+  (\es -> return $ Base es)
+elemToBase _ _ = throwError WrongElem
 
 elemToNAryStyle :: NameSpaces -> Element -> NAryStyle
 elemToNAryStyle ns element
@@ -721,225 +644,287 @@ elemToGroupStyle ns element
      GroupStyle { groupChr = chr, groupPos = pos }
 elemToGroupStyle _ _ = defaultGroupStyle
 
-elemToMathElem :: NameSpaces -> Element -> Maybe OMathElem
-elemToMathElem ns element
-  | qName (elName element) == "acc" &&
-    qURI (elName element) == (lookup "m" ns) = do
-      let accChar =
-            findChild (QName "accPr" (lookup "m" ns) (Just "m")) element >>=
-            findChild (QName "chr" (lookup "m" ns) (Just "m")) >>=
-            findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
-            Just . head
-          accPr = AccentStyle { accentChar = accChar}
-      base <-findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
-             elemToBase ns
-      return $ Accent accPr base
-elemToMathElem ns element
-  | qName (elName element) == "bar" &&
-    qURI (elName element) == (lookup "m" ns) = do
-      barPr <- findChild (QName "barPr" (lookup "m" ns) (Just "m")) element >>=
-               findChild (QName "pos" (lookup "m" ns) (Just "m")) >>=
-               findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
-               (\s ->
-                 Just $ BarStyle {
-                   barPos = (if s == "bot" then Bottom else Top)
-                   })
-      base <-findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
-             elemToBase ns
-      return $ Bar barPr base
-elemToMathElem ns element
-  | qName (elName element) == "box" &&
-    qURI (elName element) == (lookup "m" ns) =
-      findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
-      elemToBase ns >>=
-      (\b -> Just $ Box b)
-elemToMathElem ns element
-  | qName (elName element) == "borderBox" &&
-    qURI (elName element) == (lookup "m" ns) =
-      findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
-      elemToBase ns >>=
-      (\b -> Just $ BorderBox b)
-elemToMathElem ns element
-  | qName (elName element) == "d" &&
-    qURI (elName element) == (lookup "m" ns) =
-      let style = elemToDelimStyle ns element
-      in
-       Just $ Delimiter style $ mapMaybe (elemToBase ns) (elChildren element)
-elemToMathElem ns element
-  | qName (elName element) == "eqArr" &&
-    qURI (elName element) == (lookup "m" ns) =
-       Just $ EquationArray
-       $ mapMaybe (elemToBase ns) (elChildren element)
-elemToMathElem ns element
-  | qName (elName element) == "f" &&
-    qURI (elName element) == (lookup "m" ns) = do
-      num <- findChild (QName "num" (lookup "m" ns) (Just "m")) element 
-      den <- findChild (QName "den" (lookup "m" ns) (Just "m")) element 
-      let numElems = mapMaybe (elemToMathElem ns) (elChildren num)
-          denElems = mapMaybe (elemToMathElem ns) (elChildren den)
-      return $ Fraction numElems denElems
-elemToMathElem ns element
-  | qName (elName element) == "func" &&
-    qURI (elName element) == (lookup "m" ns) = do
-      fName <- findChild (QName "fName" (lookup "m" ns) (Just "m")) element
-      base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
-           elemToBase ns
-      let fnElems = mapMaybe (elemToMathElem ns) (elChildren fName)
-      return $ Function fnElems base
-elemToMathElem ns element
-  | qName (elName element) == "groupChr" &&
-    qURI (elName element) == (lookup "m" ns) =
-      let style = elemToGroupStyle ns element
-      in
-       findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
-       elemToBase ns >>=
-       (\b -> Just $ Group style b)
-elemToMathElem ns element
-  | qName (elName element) == "limLow" &&
-    qURI (elName element) == (lookup "m" ns) = do
-      base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element
-              >>= elemToBase ns
-      lim <- findChild (QName "lim" (lookup "m" ns) (Just "m")) element
-      return $ LowerLimit base (mapMaybe (elemToMathElem ns) (elChildren lim))
-elemToMathElem ns element
-  | qName (elName element) == "limUpp" &&
-    qURI (elName element) == (lookup "m" ns) = do
-      base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element
-              >>= elemToBase ns
-      lim <- findChild (QName "lim" (lookup "m" ns) (Just "m")) element
-      return $ UpperLimit base (mapMaybe (elemToMathElem ns) (elChildren lim))
-elemToMathElem ns element
-  | qName (elName element) == "m" &&
-    qURI (elName element) == (lookup "m" ns) =
-      let rows = findChildren (QName "mr" (lookup "m" ns) (Just "m")) element
-          bases = map (\mr -> mapMaybe (elemToBase ns) (elChildren mr)) rows
-      in
-       Just $ Matrix bases
-elemToMathElem ns element
-  | qName (elName element) == "nary" &&
-    qURI (elName element) == (lookup "m" ns) = do
-      let style = elemToNAryStyle ns element
-      sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=
-             (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
-      sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=
-             (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
-      base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
-              elemToBase ns
-      return $ NAry style sub sup base
-elemToMathElem ns element
-  | qName (elName element) == "rad" &&
-    qURI (elName element) == (lookup "m" ns) = do
-      deg <- findChild (QName "deg" (lookup "m" ns) (Just "m")) element >>=
-             (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
-      base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
-              elemToBase ns
-      return $ Radical deg base
--- skipping for now:
--- phant
-elemToMathElem ns element
-  | qName (elName element) == "sPre" &&
-    qURI (elName element) == (lookup "m" ns) = do
-      sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=
-             (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
-      sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=
-             (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
-      base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
-              elemToBase ns
-      return $ PreSubSuper sub sup base
-elemToMathElem ns element
-  | qName (elName element) == "sSub" &&
-    qURI (elName element) == (lookup "m" ns) = do
-      base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
-              elemToBase ns
-      sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=
-             (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
-      return $ Sub base sub
-elemToMathElem ns element
-  | qName (elName element) == "sSubSup" &&
-    qURI (elName element) == (lookup "m" ns) = do
-      base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
-              elemToBase ns
-      sub <- findChild (QName "sub" (lookup "m" ns) (Just "m")) element >>=
-             (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
-      sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=
-             (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
-      return $ SubSuper base sub sup
-elemToMathElem ns element
-  | qName (elName element) == "sSup" &&
-    qURI (elName element) == (lookup "m" ns) = do
-      base <- findChild (QName "e" (lookup "m" ns) (Just "m")) element >>=
-              elemToBase ns
-      sup <- findChild (QName "sup" (lookup "m" ns) (Just "m")) element >>=
-             (\e -> Just $ mapMaybe (elemToMathElem ns) (elChildren e))
-      return $ Super base sup
-elemToMathElem ns element
-  | qName (elName element) == "r" &&
-    qURI (elName element) == (lookup "m" ns) = 
-      let style = []            -- placeholder
-          rstyle = elemToRunStyle ns element
-          relems = elemToRunElems ns element
-      in
-       Just $ OMathRun style $ Run rstyle relems
-elemToMathElem _ _ = Nothing
+elemToMathElem :: NameSpaces -> Element -> D OMathElem
+elemToMathElem ns element | isElem ns "m" "acc" element = do
+  let accChar =
+        findChild (QName "accPr" (lookup "m" ns) (Just "m")) element >>=
+        findChild (QName "chr" (lookup "m" ns) (Just "m")) >>=
+        findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
+        Just . head
+      accPr = AccentStyle { accentChar = accChar}
+  base <-(maybeToD $ findChild (elemName ns "m" "e") element) >>=
+         elemToBase ns
+  return $ Accent accPr base
+elemToMathElem ns element | isElem ns "m" "bar" element = do
+  barPr <- maybeToD $
+          findChild (QName "barPr" (lookup "m" ns) (Just "m")) element >>=
+          findChild (QName "pos" (lookup "m" ns) (Just "m")) >>=
+          findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
+          (\s ->
+            Just $ BarStyle {
+              barPos = (if s == "bot" then Bottom else Top)
+              })
+  base <-maybeToD (findChild (QName "e" (lookup "m" ns) (Just "m")) element) >>=
+         elemToBase ns
+  return $ Bar barPr base
+elemToMathElem ns element | isElem ns "m" "box" element = 
+  maybeToD (findChild (elemName ns "m" "e") element) >>=
+  elemToBase ns >>=
+  (\b -> return $ Box b)
+elemToMathElem ns element | isElem ns "m" "borderBox" element = 
+  maybeToD (findChild (elemName ns "m" "e") element) >>=
+  elemToBase ns >>=
+  (\b -> return $ BorderBox b)
+elemToMathElem ns element | isElem ns "m" "d" element = 
+  let style = elemToDelimStyle ns element
+  in
+   mapD (elemToBase ns) (elChildren element) >>=
+   (\es -> return $ Delimiter style es)
+elemToMathElem ns element | isElem ns "m" "eqArr" element =
+  mapD (elemToBase ns) (elChildren element) >>=
+  (\es -> return $ EquationArray es)
+elemToMathElem ns element | isElem ns "m" "f" element = do
+  num <- maybeToD $ findChild (elemName ns "m" "num") element 
+  den <- maybeToD $ findChild (elemName ns "m" "den") element 
+  numElems <- mapD (elemToMathElem ns) (elChildren num)
+  denElems <- mapD (elemToMathElem ns) (elChildren den)
+  return $ Fraction numElems denElems
+elemToMathElem ns element | isElem ns "m" "func" element = do
+  fName <- maybeToD $ findChild (elemName ns "m" "fName") element
+  base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
+          elemToBase ns
+  fnElems <- mapD (elemToMathElem ns) (elChildren fName)
+  return $ Function fnElems base
+elemToMathElem ns element | isElem ns "m" "groupChr" element = 
+  let style = elemToGroupStyle ns element
+  in
+   maybeToD (findChild (elemName ns "m" "e") element) >>=
+   elemToBase ns >>=
+   (\b -> return $ Group style b)
+elemToMathElem ns element | isElem ns "m" "limLow" element = do
+  base <- maybeToD (findChild (elemName ns "m" "e") element)
+          >>= elemToBase ns
+  lim <- maybeToD $ findChild (elemName ns "m" "lim") element
+  limElems <- mapD (elemToMathElem ns) (elChildren lim)
+  return $ LowerLimit base limElems
+elemToMathElem ns element | isElem ns "m" "limUpp" element = do
+  base <- maybeToD (findChild (elemName ns "m" "e") element)
+          >>= elemToBase ns
+  lim <- maybeToD $ findChild (elemName ns "m" "lim") element
+  limElems <- mapD (elemToMathElem ns) (elChildren lim)
+  return $ UpperLimit base limElems
+elemToMathElem ns element | isElem ns "m" "m" element = do
+  let rows = findChildren (elemName ns "m" "mr") element
+  bases <- mapD (\mr -> mapD (elemToBase ns) (elChildren mr)) rows
+  return $ Matrix bases
+elemToMathElem ns element | isElem ns "m" "nary" element = do
+  let style = elemToNAryStyle ns element
+  sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>=
+         (\e -> mapD (elemToMathElem ns) (elChildren e))
+  sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>=
+         (\e -> mapD (elemToMathElem ns) (elChildren e))
+  base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
+          elemToBase ns
+  return $ NAry style sub sup base
+elemToMathElem ns element | isElem ns "m" "rad" element = do
+  deg <- maybeToD (findChild (elemName ns "m" "deg") element) >>=
+         (\e -> mapD (elemToMathElem ns) (elChildren e))
+  base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
+          elemToBase ns
+  return $ Radical deg base
+elemToMathElem ns element | isElem ns "m" "phant" element = do
+  base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
+          elemToBase ns
+  return $ Phantom base
+elemToMathElem ns element | isElem ns "m" "sPre" element = do
+  sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>=
+         (\e -> mapD (elemToMathElem ns) (elChildren e))
+  sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>=
+         (\e -> mapD (elemToMathElem ns) (elChildren e))
+  base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
+          elemToBase ns
+  return $ PreSubSuper sub sup base
+elemToMathElem ns element | isElem ns "m" "sSub" element = do
+  base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
+          elemToBase ns
+  sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>=
+         (\e -> mapD (elemToMathElem ns) (elChildren e))
+  return $ Sub base sub
+elemToMathElem ns element | isElem ns "m" "sSubSup" element = do
+  base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
+          elemToBase ns
+  sub <- maybeToD (findChild (elemName ns "m" "sub") element) >>=
+         (\e -> mapD (elemToMathElem ns) (elChildren e))
+  sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>=
+         (\e -> mapD (elemToMathElem ns) (elChildren e))
+  return $ SubSuper base sub sup
+elemToMathElem ns element | isElem ns "m" "sSup" element = do
+  base <- maybeToD (findChild (elemName ns "m" "e") element) >>=
+          elemToBase ns
+  sup <- maybeToD (findChild (elemName ns "m" "sup") element) >>=
+         (\e -> mapD (elemToMathElem ns) (elChildren e))
+  return $ Sub base sup
+elemToMathElem ns element | isElem ns "m" "r" element = do
+  let style = []            -- placeholder
+      rstyle = elemToRunStyle ns element
+  relems <- elemToRunElems ns element
+  return $ OMathRun style $ Run rstyle relems
+elemToMathElem _ _ = throwError WrongElem
 
+lookupRelationship :: RelId -> [Relationship] -> Maybe Target
+lookupRelationship relid rels =
+  lookup relid (map (\(Relationship pair) -> pair) rels)
 
-          
-elemToParPart :: NameSpaces -> Element -> Maybe ParPart
+expandDrawingId :: String -> D ParPart
+expandDrawingId s = do
+  target <- asks (lookupRelationship s . envRelationships)
+  case target of
+    Just t -> do let filepath = combine "word" t
+                 bytes <- asks (lookup filepath . envMedia)
+                 case bytes of
+                   Just bs -> return $ Drawing filepath bs
+                   Nothing -> throwError DocxError
+    Nothing -> throwError DocxError
+
+elemToParPart :: NameSpaces -> Element -> D ParPart
 elemToParPart ns element
-  | qName (elName element) == "r" &&
-    qURI (elName element) == (lookup "w" ns) =
-      case findChild (QName "drawing" (lookup "w" ns) (Just "w")) element of
-        Just drawingElem -> elemToDrawing ns drawingElem
-        Nothing -> do
-          r <- elemToRun ns element
-          return $ PlainRun r
+  | isElem ns "w" "r" element
+  , Just _ <- findChild (elemName ns "w" "drawing") element =
+    let a_ns = "http://schemas.openxmlformats.org/drawingml/2006/main"
+        drawing = findElement (QName "blip" (Just a_ns) (Just "a")) element
+                  >>= findAttr (QName "embed" (lookup "r" ns) (Just "r"))
+    in
+     case drawing of
+       Just s -> expandDrawingId s
+       Nothing -> throwError WrongElem
 elemToParPart ns element
-  | qName (elName element) == "ins" &&
-    qURI (elName element) == (lookup "w" ns) = do
-      cId <- findAttr (QName "id" (lookup "w" ns) (Just "w")) element
-      cAuthor <- findAttr (QName "author" (lookup "w" ns) (Just "w")) element
-      cDate <- findAttr (QName "date" (lookup "w" ns) (Just "w")) element
-      let runs = mapMaybe (elemToRun ns) (elChildren element)
-      return $ Insertion cId cAuthor cDate runs
+  | isElem ns "w" "r" element =
+    elemToRun ns element >>= (\r -> return $ PlainRun r)
 elemToParPart ns element
-  | qName (elName element) == "del" &&
-    qURI (elName element) == (lookup "w" ns) = do
-      cId <- findAttr (QName "id" (lookup "w" ns) (Just "w")) element
-      cAuthor <- findAttr (QName "author" (lookup "w" ns) (Just "w")) element
-      cDate <- findAttr (QName "date" (lookup "w" ns) (Just "w")) element
-      let runs = mapMaybe (elemToRun ns) (elChildren element)
-      return $ Deletion cId cAuthor cDate runs
+  | isElem ns "w" "ins" element
+  , Just cId <- findAttr (elemName ns "w" "id") element
+  , Just cAuthor <- findAttr (elemName ns "w" "author") element
+  , Just cDate <- findAttr (elemName ns "w" "date") element = do
+    runs <- mapD (elemToRun ns) (elChildren element)
+    return $ Insertion cId cAuthor cDate runs
 elemToParPart ns element
-  | qName (elName element) == "bookmarkStart" &&
-    qURI (elName element) == (lookup "w" ns) = do
-      bmId <- findAttr (QName "id" (lookup "w" ns) (Just "w")) element
-      bmName <- findAttr (QName "name" (lookup "w" ns) (Just "w")) element
-      return $ BookMark bmId bmName
+  | isElem ns "w" "del" element
+  , Just cId <- findAttr (elemName ns "w" "id") element
+  , Just cAuthor <- findAttr (elemName ns "w" "author") element
+  , Just cDate <- findAttr (elemName ns "w" "date") element = do
+    runs <- mapD (elemToRun ns) (elChildren element)
+    return $ Deletion cId cAuthor cDate runs
 elemToParPart ns element
-  | qName (elName element) == "hyperlink" &&
-    qURI (elName element) == (lookup "w" ns) =
-      let runs = mapMaybe (elemToRun ns)
-                 $ findChildren (QName "r" (lookup "w" ns) (Just "w")) element
-      in
-       case findAttr (QName "anchor" (lookup "w" ns) (Just "w")) element of
-         Just anchor ->
-          Just $ InternalHyperLink anchor runs
-         Nothing ->
-           case findAttr (QName "id" (lookup "r" ns) (Just "r")) element of
-             Just relId -> Just $ ExternalHyperLink relId runs
-             Nothing    -> Nothing
+  | isElem ns "w" "bookmarkStart" element
+  , Just bmId <- findAttr (elemName ns "w" "id") element
+  , Just bmName <- findAttr (elemName ns "w" "name") element =
+    return $ BookMark bmId bmName
+elemToParPart ns element
+  | isElem ns "w" "hyperlink" element
+  , Just anchor <- findAttr (elemName ns "w" "anchor") element = do
+    runs <- mapD (elemToRun ns) (elChildren element)
+    return $ InternalHyperLink anchor runs
 elemToParPart ns element
-  | qName (elName element) == "oMath" &&
-    qURI (elName element) == (lookup "m" ns) =
-      elemToMath ns element >>=
-      (\m -> Just $ PlainOMath m)
-elemToParPart _ _ = Nothing
+  | isElem ns "w" "hyperlink" element
+  , Just relId <- findAttr (elemName ns "r" "id") element = do
+    runs <- mapD (elemToRun ns) (elChildren element)
+    rels <- asks envRelationships
+    return $ case lookupRelationship relId rels of
+      Just target -> ExternalHyperLink target runs
+      Nothing     -> ExternalHyperLink "" runs
+elemToParPart _ _ = throwError WrongElem
+
+lookupFootnote :: String -> Notes -> Maybe Element
+lookupFootnote s (Notes _ fns _) = fns >>= (M.lookup s)
+
+lookupEndnote :: String -> Notes -> Maybe Element
+lookupEndnote s (Notes _ _ ens) = ens >>= (M.lookup s)
+
+elemToRun :: NameSpaces -> Element -> D Run
+elemToRun ns element
+  | isElem ns "w" "r" element
+  , Just ref <- findChild (elemName ns "w" "footnoteReference") element
+  , Just fnId <- findAttr (elemName ns "w" "id") ref = do
+    notes <- asks envNotes
+    case lookupFootnote fnId notes of
+      Just e -> do bps <- mapD (elemToBodyPart ns) (elChildren e)
+                   return $ Footnote bps
+      Nothing  -> return $ Footnote []
+elemToRun ns element
+  | isElem ns "w" "r" element
+  , Just ref <- findChild (elemName ns "w" "endnoteReference") element
+  , Just enId <- findAttr (elemName ns "w" "id") ref = do
+    notes <- asks envNotes
+    case lookupEndnote enId notes of
+      Just e -> do bps <- mapD (elemToBodyPart ns) (elChildren e)
+                   return $ Footnote bps
+      Nothing  -> return $ Footnote []
+elemToRun ns element
+  | isElem ns "w" "r" element = do
+    runElems <- elemToRunElems ns element
+    return $ Run (elemToRunStyle ns element) runElems
+elemToRun _ _ = throwError WrongElem
+
+elemToParagraphStyle :: NameSpaces -> Element -> ParagraphStyle
+elemToParagraphStyle ns element
+  | Just pPr <- findChild (elemName ns "w" "pPr") element =
+    ParagraphStyle
+      {pStyle =
+          mapMaybe
+          (findAttr (elemName ns "w" "val"))
+          (findChildren (elemName ns "w" "pStyle") pPr)
+      , indentation =
+            findChild (elemName ns "w" "ind") pPr >>=
+            elemToParIndentation ns
+      }
+elemToParagraphStyle _ _ =  defaultParagraphStyle
 
 
-type Target = String
-type Anchor = String
-type BookMarkId = String
-type RelId = String
-type ChangeId = String
-type Author = String
-type ChangeDate = String               
+elemToRunStyle :: NameSpaces -> Element -> RunStyle
+elemToRunStyle ns element
+  | Just rPr <- findChild (elemName ns "w" "rPr") element =
+    RunStyle
+      {
+        isBold = isJust $ findChild (QName "b" (lookup "w" ns) (Just "w")) rPr
+      , isItalic = isJust $ findChild (QName "i" (lookup "w" ns) (Just "w")) rPr
+      , isSmallCaps = isJust $ findChild (QName "smallCaps" (lookup "w" ns) (Just "w")) rPr
+      , isStrike = isJust $ findChild (QName "strike" (lookup "w" ns) (Just "w")) rPr
+      , isSuperScript =
+        (Just "superscript" ==
+        (findChild (QName "vertAlign" (lookup "w" ns) (Just "w")) rPr >>=
+         findAttr (QName "val" (lookup "w" ns) (Just "w"))))
+      , isSubScript =
+        (Just "subscript" ==
+        (findChild (QName "vertAlign" (lookup "w" ns) (Just "w")) rPr >>=
+         findAttr (QName "val" (lookup "w" ns) (Just "w"))))
+      , rUnderline =
+        findChild (QName "u" (lookup "w" ns) (Just "w")) rPr >>=
+        findAttr (QName "val" (lookup "w" ns) (Just "w"))
+      , rStyle =
+        findChild (QName "rStyle" (lookup "w" ns) (Just "w")) rPr >>=
+        findAttr (QName "val" (lookup "w" ns) (Just "w"))
+        }
+elemToRunStyle _ _ = defaultRunStyle
+
+elemToRunElem :: NameSpaces -> Element -> D RunElem
+elemToRunElem ns element
+  | isElem ns "w" "t" element || isElem ns "w" "delText" element =
+    return $ TextRun $ strContent element
+  | isElem ns "w" "br" element = return LnBrk
+  | isElem ns "w" "tab" element = return Tab
+  | otherwise = throwError WrongElem
+
+elemToRunElems :: NameSpaces -> Element -> D [RunElem]
+elemToRunElems ns element
+  |  isElem ns "w" "r" element = mapD (elemToRunElem ns) (elChildren element)
+elemToRunElems _ _ = throwError WrongElem
+
+
+     
+    
+
+
+
+
+  
+