10 files changed, 776 insertions, 802 deletions
diff --git a/src/Text/Pandoc/Readers/Docx.hs b/src/Text/Pandoc/Readers/Docx.hs
index 9f73f2e7f..882e8d7d8 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 }
@@ -151,7 +150,7 @@ runStyleToContainers rPr =
       classContainers = case rStyle rPr of
         Nothing -> []
         Just s  -> spanClassToContainers s
-      
+
       formatters = map Container $ mapMaybe id
                    [ if isBold rPr then (Just Strong) else Nothing
                    , if isItalic rPr then (Just Emph) else Nothing
@@ -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
@@ -189,7 +188,7 @@ parStyleToContainers pPr | (c:cs) <- pStyle pPr, c `elem` blockQuoteDivs =
 parStyleToContainers pPr | (_:cs) <- pStyle pPr =
   let pPr' = pPr { pStyle = cs}
   in
-    parStyleToContainers pPr'                                 
+    parStyleToContainers pPr'
 parStyleToContainers pPr | null (pStyle pPr),
                           Just left <- indentation pPr >>= leftParIndent,
                           Just hang <- indentation pPr >>= hangingParIndent =
@@ -206,7 +205,7 @@ parStyleToContainers pPr | null (pStyle pPr),
      True -> (Container BlockQuote) : (parStyleToContainers pPr')
      False -> parStyleToContainers pPr'
 parStyleToContainers _ = []
-  
+
 
 strToInlines :: String -> [Inline]
 strToInlines = toList . text
@@ -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]
@@ -351,7 +343,7 @@ oMathElemToTexString (Bar style base) = do
     Top    -> printf "\\overline{%s}" baseString
     Bottom -> printf "\\underline{%s}" baseString
 oMathElemToTexString (Box base) = baseToTexString base
-oMathElemToTexString (BorderBox base) = 
+oMathElemToTexString (BorderBox base) =
   baseToTexString base >>= (\s -> return $ printf "\\boxed{%s}" s)
 oMathElemToTexString (Delimiter dPr bases) = do
   let beg = fromMaybe '(' (delimBegChar dPr)
@@ -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,12 +470,11 @@ 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) =
   concatMapM oMathElemToTexString mathElems
-  
+
 
 isAnchorSpan :: Inline -> Bool
 isAnchorSpan (Span (ident, classes, kvs) ils) =
@@ -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]
@@ -543,7 +535,7 @@ bodyPartToBlocks (Paragraph pPr parparts)
     let
       otherConts = filter (not . isBlockCodeContainer) (parStyleToContainers pPr)
     in
-     return $ 
+     return $
      rebuild
      otherConts
      [CodeBlock ("", [], []) (concatMap parPartToString parparts)]
@@ -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 _ _ _ []) =
@@ -592,7 +582,7 @@ bodyPartToBlocks (Tbl cap _ look (r:rs)) = do
   hdrCells <- case hdr of
     Just r' -> rowToBlocksList r'
     Nothing -> return []
-        
+
   cells <- mapM rowToBlocksList rows
 
   let size = case null hdrCells of
@@ -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/Lists.hs b/src/Text/Pandoc/Readers/Docx/Lists.hs
index 1e37d0076..ea195c14a 100644
--- a/src/Text/Pandoc/Readers/Docx/Lists.hs
+++ b/src/Text/Pandoc/Readers/Docx/Lists.hs
@@ -121,7 +121,7 @@ handleListParagraphs (
       in
        handleListParagraphs ((Div attr1 (blks1 ++ [newDiv2])) : blks)
 handleListParagraphs (blk:blks) = blk : (handleListParagraphs blks)
-                  
+
 separateBlocks' :: Block -> [[Block]] -> [[Block]]
 separateBlocks' blk ([] : []) = [[blk]]
 separateBlocks' b@(BulletList _) acc = (init acc) ++ [(last acc) ++ [b]]
@@ -139,7 +139,7 @@ flatToBullets' :: Integer -> [Block] -> [Block]
 flatToBullets' _ [] = []
 flatToBullets' num xs@(b : elems)
   | getLevelN b == num = b : (flatToBullets' num elems)
-  | otherwise = 
+  | otherwise =
     let bNumId = getNumIdN b
         bLevel = getLevelN b
         (children, remaining) =
@@ -162,7 +162,7 @@ flatToBullets elems = flatToBullets' (-1) elems
 
 blocksToBullets :: [Block] -> [Block]
 blocksToBullets blks =
-  bottomUp removeListDivs $ 
+  bottomUp removeListDivs $
   flatToBullets $ (handleListParagraphs blks)
 
 plainParaInlines :: Block -> [Inline]
@@ -216,12 +216,12 @@ removeListDivs' blk = [blk]
 
 removeListDivs :: [Block] -> [Block]
 removeListDivs = concatMap removeListDivs'
-  
+
 
 
 blocksToDefinitions :: [Block] -> [Block]
 blocksToDefinitions = blocksToDefinitions' [] []
 
-    
-    
-    
+
+
+
diff --git a/src/Text/Pandoc/Readers/Docx/Parse.hs b/src/Text/Pandoc/Readers/Docx/Parse.hs
index 44585b016..8541a1a3a 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 Text.Pandoc.Compat.Except
+
+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 = ExceptT DocxError (Reader ReaderEnv)
+
+runD :: D a -> ReaderEnv -> Either DocxError a
+runD dx re = runReader (runExceptT 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 
+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
+
+---------------------------------------------
+---------------------------------------------
+
+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)
+
+
+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
 
-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
+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)])
 
-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
+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
-  | 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 anchor <- findAttr (elemName ns "w" "anchor") element = do
+    runs <- mapD (elemToRun ns) (elChildren element)
+    return $ InternalHyperLink anchor runs
+elemToParPart ns element
+  | 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
+
+
+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
+
+
+
+
+
+
+
+
 
 
-type Target = String
-type Anchor = String
-type BookMarkId = String
-type RelId = String
-type ChangeId = String
-type Author = String
-type ChangeDate = String               
diff --git a/src/Text/Pandoc/Readers/Docx/Reducible.hs b/src/Text/Pandoc/Readers/Docx/Reducible.hs
index 8c105d1f1..e8e407844 100644
--- a/src/Text/Pandoc/Readers/Docx/Reducible.hs
+++ b/src/Text/Pandoc/Readers/Docx/Reducible.hs
@@ -90,7 +90,7 @@ combineReducibles r s =
        True -> case (not . null) rs && isSpace (last rs) of
          True -> rebuild conts (init rs) ++ [last rs, s]
          False -> [r,s]
-       False -> rebuild 
+       False -> rebuild
                 shared $
                 reduceList $
                 (rebuild remaining rs) ++ (rebuild remaining' ss)
@@ -145,7 +145,7 @@ instance Reducible Inline where
   isSpace _     = False
 
 instance Reducible Block where
-  (Div (ident, classes, kvs) blks) <++> blk | "list-item" `elem` classes = 
+  (Div (ident, classes, kvs) blks) <++> blk | "list-item" `elem` classes =
     [Div (ident, classes, kvs) (reduceList blks), blk]
 
   blk <++> blk' = combineReducibles blk blk'
@@ -177,5 +177,5 @@ rebuild :: [Container a] -> [a] -> [a]
 rebuild [] xs = xs
 rebuild ((Container f) : cs) xs = rebuild cs $ [f xs]
 rebuild (NullContainer : cs) xs = rebuild cs $ xs
-  
-  
+
+
diff --git a/src/Text/Pandoc/Readers/Docx/TexChar.hs b/src/Text/Pandoc/Readers/Docx/TexChar.hs
index 1bef8d7da..eddcabecc 100644
--- a/src/Text/Pandoc/Readers/Docx/TexChar.hs
+++ b/src/Text/Pandoc/Readers/Docx/TexChar.hs
@@ -4382,5 +4382,5 @@ uniconvMap = M.fromList [ ('\8193', "\\quad")
 --                         , ('\120829', "\\mttseven")
 --                         , ('\120830', "\\mtteight")
 --                         , ('\120831', "\\mttnine")
-  
+
 --                         ]
diff --git a/src/Text/Pandoc/Readers/HTML.hs b/src/Text/Pandoc/Readers/HTML.hs
index 381b67e18..cedbb8c9e 100644
--- a/src/Text/Pandoc/Readers/HTML.hs
+++ b/src/Text/Pandoc/Readers/HTML.hs
@@ -128,7 +128,7 @@ pBulletList = try $ do
   -- note: if they have an <ol> or <ul> not in scope of a <li>,
   -- treat it as a list item, though it's not valid xhtml...
   skipMany nonItem
-  items <- manyTill (pInTags "li" block >>~ skipMany nonItem) (pCloses "ul")
+  items <- manyTill (pInTags "li" block <* skipMany nonItem) (pCloses "ul")
   return $ B.bulletList $ map (fixPlains True) items
 
 pOrderedList :: TagParser Blocks
@@ -156,7 +156,7 @@ pOrderedList = try $ do
   -- note: if they have an <ol> or <ul> not in scope of a <li>,
   -- treat it as a list item, though it's not valid xhtml...
   skipMany nonItem
-  items <- manyTill (pInTags "li" block >>~ skipMany nonItem) (pCloses "ol")
+  items <- manyTill (pInTags "li" block <* skipMany nonItem) (pCloses "ol")
   return $ B.orderedListWith (start, style, DefaultDelim) $ map (fixPlains True) items
 
 pDefinitionList :: TagParser Blocks
@@ -244,7 +244,7 @@ pTable :: TagParser Blocks
 pTable = try $ do
   TagOpen _ _ <- pSatisfy (~== TagOpen "table" [])
   skipMany pBlank
-  caption <- option mempty $ pInTags "caption" inline >>~ skipMany pBlank
+  caption <- option mempty $ pInTags "caption" inline <* skipMany pBlank
   -- TODO actually read these and take width information from them
   widths' <- pColgroup <|> many pCol
   head' <- option [] $ pOptInTag "thead" $ pInTags "tr" (pCell "th")
diff --git a/src/Text/Pandoc/Readers/LaTeX.hs b/src/Text/Pandoc/Readers/LaTeX.hs
index 97bfaa455..339f8e3c9 100644
--- a/src/Text/Pandoc/Readers/LaTeX.hs
+++ b/src/Text/Pandoc/Readers/LaTeX.hs
@@ -104,7 +104,7 @@ dimenarg = try $ do
 
 sp :: LP ()
 sp = skipMany1 $ satisfy (\c -> c == ' ' || c == '\t')
-        <|> (try $ newline >>~ lookAhead anyChar >>~ notFollowedBy blankline)
+        <|> (try $ newline <* lookAhead anyChar <* notFollowedBy blankline)
 
 isLowerHex :: Char -> Bool
 isLowerHex x = x >= '0' && x <= '9' || x >= 'a' && x <= 'f'
diff --git a/src/Text/Pandoc/Readers/Markdown.hs b/src/Text/Pandoc/Readers/Markdown.hs
index 80d6698de..1e74f051c 100644
--- a/src/Text/Pandoc/Readers/Markdown.hs
+++ b/src/Text/Pandoc/Readers/Markdown.hs
@@ -571,7 +571,7 @@ attributes :: MarkdownParser Attr
 attributes = try $ do
   char '{'
   spnl
-  attrs <- many (attribute >>~ spnl)
+  attrs <- many (attribute <* spnl)
   char '}'
   return $ foldl (\x f -> f x) nullAttr attrs
 
@@ -688,7 +688,7 @@ birdTrackLine c = try $ do
 --
 
 emailBlockQuoteStart :: MarkdownParser Char
-emailBlockQuoteStart = try $ skipNonindentSpaces >> char '>' >>~ optional (char ' ')
+emailBlockQuoteStart = try $ skipNonindentSpaces >> char '>' <* optional (char ' ')
 
 emailBlockQuote :: MarkdownParser [String]
 emailBlockQuote = try $ do
@@ -948,7 +948,7 @@ rawVerbatimBlock = try $ do
                                                   ["pre", "style", "script"])
                               (const True))
   contents <- manyTill anyChar (htmlTag (~== TagClose tag))
-  return $ open ++ contents ++ renderTags [TagClose tag]
+  return $ open ++ contents ++ renderTags' [TagClose tag]
 
 rawTeXBlock :: MarkdownParser (F Blocks)
 rawTeXBlock = do
@@ -1165,7 +1165,7 @@ gridPart ch = do
   return (length dashes, length dashes + 1)
 
 gridDashedLines :: Char -> Parser [Char] st [(Int,Int)]
-gridDashedLines ch = try $ char '+' >> many1 (gridPart ch) >>~ blankline
+gridDashedLines ch = try $ char '+' >> many1 (gridPart ch) <* blankline
 
 removeFinalBar :: String -> String
 removeFinalBar =
@@ -1436,52 +1436,60 @@ math =  (return . B.displayMath <$> (mathDisplay >>= applyMacros'))
 enclosure :: Char
           -> MarkdownParser (F Inlines)
 enclosure c = do
+  -- we can't start an enclosure with _ if after a string and
+  -- the intraword_underscores extension is enabled:
+  guardDisabled Ext_intraword_underscores
+    <|> guard (c == '*')
+    <|> (guard =<< notAfterString)
   cs <- many1 (char c)
   (return (B.str cs) <>) <$> whitespace
-    <|> case length cs of
+    <|> do
+        case length cs of
              3  -> three c
              2  -> two   c mempty
              1  -> one   c mempty
              _  -> return (return $ B.str cs)
 
+ender :: Char -> Int -> MarkdownParser ()
+ender c n = try $ do
+  count n (char c)
+  guard (c == '*')
+    <|> guardDisabled Ext_intraword_underscores
+    <|> notFollowedBy alphaNum
+
 -- Parse inlines til you hit one c or a sequence of two cs.
 -- If one c, emit emph and then parse two.
 -- If two cs, emit strong and then parse one.
 -- Otherwise, emit ccc then the results.
 three :: Char -> MarkdownParser (F Inlines)
 three c = do
-  contents <- mconcat <$> many (notFollowedBy (char c) >> inline)
-  (try (string [c,c,c]) >> return ((B.strong . B.emph) <$> contents))
-    <|> (try (string [c,c]) >> one c (B.strong <$> contents))
-    <|> (char c >> two c (B.emph <$> contents))
+  contents <- mconcat <$> many (notFollowedBy (ender c 1) >> inline)
+  (ender c 3 >> return ((B.strong . B.emph) <$> contents))
+    <|> (ender c 2 >> one c (B.strong <$> contents))
+    <|> (ender c 1 >> two c (B.emph <$> contents))
     <|> return (return (B.str [c,c,c]) <> contents)
 
 -- Parse inlines til you hit two c's, and emit strong.
 -- If you never do hit two cs, emit ** plus inlines parsed.
 two :: Char -> F Inlines -> MarkdownParser (F Inlines)
 two c prefix' = do
-  let ender = try $ string [c,c]
-  contents <- mconcat <$> many (try $ notFollowedBy ender >> inline)
-  (ender >> return (B.strong <$> (prefix' <> contents)))
+  contents <- mconcat <$> many (try $ notFollowedBy (ender c 2) >> inline)
+  (ender c 2 >> return (B.strong <$> (prefix' <> contents)))
     <|> return (return (B.str [c,c]) <> (prefix' <> contents))
 
 -- Parse inlines til you hit a c, and emit emph.
 -- If you never hit a c, emit * plus inlines parsed.
 one :: Char -> F Inlines -> MarkdownParser (F Inlines)
 one c prefix' = do
-  contents <- mconcat <$> many (  (notFollowedBy (char c) >> inline)
+  contents <- mconcat <$> many (  (notFollowedBy (ender c 1) >> inline)
                            <|> try (string [c,c] >>
-                                    notFollowedBy (char c) >>
+                                    notFollowedBy (ender c 1) >>
                                     two c mempty) )
-  (char c >> return (B.emph <$> (prefix' <> contents)))
+  (ender c 1 >> return (B.emph <$> (prefix' <> contents)))
     <|> return (return (B.str [c]) <> (prefix' <> contents))
 
 strongOrEmph :: MarkdownParser (F Inlines)
-strongOrEmph =  enclosure '*' <|> (checkIntraword >> enclosure '_')
-  where  checkIntraword = do
-           exts <- getOption readerExtensions
-           when (Ext_intraword_underscores `Set.member` exts) $ do
-             guard =<< notAfterString
+strongOrEmph =  enclosure '*' <|> enclosure '_'
 
 -- | Parses a list of inlines between start and end delimiters.
 inlinesBetween :: (Show b)
@@ -1491,7 +1499,7 @@ inlinesBetween :: (Show b)
 inlinesBetween start end =
   (trimInlinesF . mconcat) <$> try (start >> many1Till inner end)
     where inner      = innerSpace <|> (notFollowedBy' (() <$ whitespace) >> inline)
-          innerSpace = try $ whitespace >>~ notFollowedBy' end
+          innerSpace = try $ whitespace <* notFollowedBy' end
 
 strikeout :: MarkdownParser (F Inlines)
 strikeout = fmap B.strikeout <$>
@@ -1749,12 +1757,17 @@ divHtml :: MarkdownParser (F Blocks)
 divHtml = try $ do
   guardEnabled Ext_markdown_in_html_blocks
   (TagOpen _ attrs, rawtag) <- htmlTag (~== TagOpen "div" [])
+  -- we set stateInHtmlBlock so that closing tags that can be either block or
+  -- inline will not be parsed as inline tags
+  oldInHtmlBlock <- stateInHtmlBlock <$> getState
+  updateState $ \st -> st{ stateInHtmlBlock = Just "div" }
   bls <- option "" (blankline >> option "" blanklines)
   contents <- mconcat <$>
               many (notFollowedBy' (htmlTag (~== TagClose "div")) >> block)
   closed <- option False (True <$ htmlTag (~== TagClose "div"))
   if closed
      then do
+       updateState $ \st -> st{ stateInHtmlBlock = oldInHtmlBlock }
        let ident = fromMaybe "" $ lookup "id" attrs
        let classes = maybe [] words $ lookup "class" attrs
        let keyvals = [(k,v) | (k,v) <- attrs, k /= "id" && k /= "class"]
diff --git a/src/Text/Pandoc/Readers/MediaWiki.hs b/src/Text/Pandoc/Readers/MediaWiki.hs
index f1dcce8f7..719bde160 100644
--- a/src/Text/Pandoc/Readers/MediaWiki.hs
+++ b/src/Text/Pandoc/Readers/MediaWiki.hs
@@ -634,7 +634,7 @@ inlinesBetween :: (Show b) => MWParser a -> MWParser b -> MWParser Inlines
 inlinesBetween start end =
   (trimInlines . mconcat) <$> try (start >> many1Till inner end)
     where inner      = innerSpace <|> (notFollowedBy' (() <$ whitespace) >> inline)
-          innerSpace = try $ whitespace >>~ notFollowedBy' end
+          innerSpace = try $ whitespace <* notFollowedBy' end
 
 emph :: MWParser Inlines
 emph = B.emph <$> nested (inlinesBetween start end)
diff --git a/src/Text/Pandoc/Readers/RST.hs b/src/Text/Pandoc/Readers/RST.hs
index fa8438e70..b7bc83e86 100644
--- a/src/Text/Pandoc/Readers/RST.hs
+++ b/src/Text/Pandoc/Readers/RST.hs
@@ -460,7 +460,7 @@ listItem :: RSTParser Int
 listItem start = try $ do
   (markerLength, first) <- rawListItem start
   rest <- many (listContinuation markerLength)
-  blanks <- choice [ try (many blankline >>~ lookAhead start),
+  blanks <- choice [ try (many blankline <* lookAhead start),
                      many1 blankline ]  -- whole list must end with blank.
   -- parsing with ListItemState forces markers at beginning of lines to
   -- count as list item markers, even if not separated by blank space.
@@ -480,7 +480,7 @@ listItem start = try $ do
 
 orderedList :: RSTParser Blocks
 orderedList = try $ do
-  (start, style, delim) <- lookAhead (anyOrderedListMarker >>~ spaceChar)
+  (start, style, delim) <- lookAhead (anyOrderedListMarker <* spaceChar)
   items <- many1 (listItem (orderedListStart style delim))
   let items' = compactify' items
   return $ B.orderedListWith (start, style, delim) items'
@@ -747,7 +747,7 @@ simpleReferenceName = do
 
 referenceName :: RSTParser Inlines
 referenceName = quotedReferenceName <|>
-                (try $ simpleReferenceName >>~ lookAhead (char ':')) <|>
+                (try $ simpleReferenceName <* lookAhead (char ':')) <|>
                 unquotedReferenceName
 
 referenceKey :: RSTParser [Char]
@@ -1076,7 +1076,7 @@ explicitLink = try $ do
 
 referenceLink :: RSTParser Inlines
 referenceLink = try $ do
-  (label',ref) <- withRaw (quotedReferenceName <|> simpleReferenceName) >>~
+  (label',ref) <- withRaw (quotedReferenceName <|> simpleReferenceName) <*
                    char '_'
   state <- getState
   let keyTable = stateKeys state