From d65fd581713f181032ac29afe9843f1de99c70e0 Mon Sep 17 00:00:00 2001 From: Jesse Rosenthal Date: Tue, 8 Jul 2014 13:22:20 -0400 Subject: 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. --- src/Text/Pandoc/Readers/Docx.hs | 108 +-- src/Text/Pandoc/Readers/Docx/Parse.hs | 1355 ++++++++++++++++----------------- 2 files changed, 712 insertions(+), 751 deletions(-) (limited to 'src/Text/Pandoc') 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 - Stability : alpha - Portability : portable + Maintainer : Jesse Rosenthal + 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 + + + + + + + + + + -- cgit v1.2.3 From fe2eda9d54e64ffa0c6c5c5295c19941040a5f3d Mon Sep 17 00:00:00 2001 From: Jesse Rosenthal Date: Sat, 12 Jul 2014 08:56:59 +0100 Subject: Docx Reader: Add a compatibility layer for Except. mtl switched from ErrorT to ExceptT, but we're not sure which mtl we'll be dealing with. This should make errors work with both. The main difference (beside the name of the module and the monad transformer) is that Except doesn't require an instance of an Error Typeclass. So we define that for compatability. When we switch to a later mtl, using Control.Monad.Exception, we can just erase the instance declaration, and all should work fine. --- pandoc.cabal | 1 + src/Text/Pandoc/Compat/Except.hs | 27 +++++++++++++++++++++++++++ src/Text/Pandoc/Readers/Docx/Parse.hs | 6 +++--- 3 files changed, 31 insertions(+), 3 deletions(-) create mode 100644 src/Text/Pandoc/Compat/Except.hs (limited to 'src/Text/Pandoc') diff --git a/pandoc.cabal b/pandoc.cabal index c049b70a1..d5e278adc 100644 --- a/pandoc.cabal +++ b/pandoc.cabal @@ -340,6 +340,7 @@ Library Text.Pandoc.Slides, Text.Pandoc.Highlighting, Text.Pandoc.Compat.Monoid, + Text.Pandoc.Compat.Except, Text.Pandoc.Compat.TagSoupEntity, Paths_pandoc diff --git a/src/Text/Pandoc/Compat/Except.hs b/src/Text/Pandoc/Compat/Except.hs new file mode 100644 index 000000000..7f5648e7a --- /dev/null +++ b/src/Text/Pandoc/Compat/Except.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} +module Text.Pandoc.Compat.Except ( ExceptT + , Error(..) + , runExceptT + , throwError + , catchError ) + where + +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except + +class Error a where + noMsg :: a + strMsg :: String -> a + + noMsg = strMsg "" + strMsg _ = noMsg + +#else +import Control.Monad.Error +type ExceptT = ErrorT + +runExceptT :: ExceptT e m a -> m (Either e a) +runExceptT = runErrorT +#endif + + diff --git a/src/Text/Pandoc/Readers/Docx/Parse.hs b/src/Text/Pandoc/Readers/Docx/Parse.hs index bb65236a3..4b5a11fa8 100644 --- a/src/Text/Pandoc/Readers/Docx/Parse.hs +++ b/src/Text/Pandoc/Readers/Docx/Parse.hs @@ -69,7 +69,7 @@ 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 +import Text.Pandoc.Compat.Except data ReaderEnv = ReaderEnv { envNotes :: Notes , envNumbering :: Numbering @@ -84,10 +84,10 @@ data DocxError = DocxError | WrongElem instance Error DocxError where noMsg = WrongElem -type D = ErrorT DocxError (Reader ReaderEnv) +type D = ExceptT DocxError (Reader ReaderEnv) runD :: D a -> ReaderEnv -> Either DocxError a -runD dx re = runReader (runErrorT dx ) re +runD dx re = runReader (runExceptT dx ) re maybeToD :: Maybe a -> D a maybeToD (Just a) = return a -- cgit v1.2.3