{-# LANGUAGE PatternGuards #-}
{-
Copyright (C) 2014 Jesse Rosenthal <jrosenthal@jhu.edu>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
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
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
-}
{- |
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
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(..)
, getFootNote
, getEndNote
, lookupLevel
, lookupRelationship
, archiveToDocx
) where
import Codec.Archive.Zip
import Text.XML.Light
import Data.Maybe
import Data.List
import System.FilePath
import Data.Bits ((.|.))
import qualified Data.ByteString.Lazy as B
import qualified Text.Pandoc.UTF8 as UTF8
attrToNSPair :: Attr -> Maybe (String, String)
attrToNSPair (Attr (QName s _ (Just "xmlns")) val) = Just (s, val)
attrToNSPair _ = Nothing
type NameSpaces = [(String, String)]
data Docx = Docx Document Notes Numbering [Relationship] Media
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
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
data Numb = Numb String String -- right now, only a key to an abstract num
deriving Show
data AbstractNumb = AbstractNumb String [Level]
deriving Show
-- (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 ParIndentation = ParIndentation { leftParIndent :: Maybe Integer
, rightParIndent :: Maybe Integer
, hangingParIndent :: Maybe Integer}
deriving Show
data ParagraphStyle = ParagraphStyle { pStyle :: [String]
, indentation :: Maybe ParIndentation
}
deriving Show
defaultParagraphStyle :: ParagraphStyle
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]
| Tbl String TblGrid TblLook [Row]
| OMathPara OMathParaStyle [OMath]
deriving Show
type TblGrid = [Integer]
data TblLook = TblLook {firstRowFormatting::Bool}
deriving Show
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
| PlainOMath OMath
deriving Show
data Run = Run RunStyle [RunElem]
| Footnote String
| Endnote String
deriving Show
data OMath = OMath [OMathElem]
deriving Show
data OMathElem = Accent AccentStyle Base
| Bar BarStyle Base
| Box Base
| BorderBox Base
| Delimiter DelimStyle [Base]
| EquationArray [Base]
| Fraction [OMathElem] [OMathElem]
| Function [OMathElem] Base
| Group GroupStyle Base
| LowerLimit Base [OMathElem]
| UpperLimit Base [OMathElem]
| Matrix [[Base]]
| NAry NAryStyle [OMathElem] [OMathElem] Base
| Phantom Base
| Radical [OMathElem] Base
| PreSubSuper [OMathElem] [OMathElem] Base
| Sub Base [OMathElem]
| SubSuper Base [OMathElem] [OMathElem]
| Super Base [OMathElem]
| OMathRun OMathRunStyle Run
deriving Show
data Base = Base [OMathElem]
deriving Show
-- placeholders
type OMathParaStyle = [String]
data TopBottom = Top | Bottom
deriving Show
data AccentStyle = AccentStyle { accentChar :: Maybe Char }
deriving Show
data BarStyle = BarStyle { barPos :: TopBottom}
deriving Show
data NAryStyle = NAryStyle { nAryChar :: Maybe Char
, nAryLimLoc :: LimLoc}
deriving Show
defaultNAryStyle :: NAryStyle
defaultNAryStyle = NAryStyle { nAryChar = Nothing -- integral, in practice
, nAryLimLoc = SubSup }
data LimLoc = SubSup | UnderOver deriving Show
data DelimStyle = DelimStyle { delimBegChar :: Maybe Char
, delimSepChar :: Maybe Char
, delimEndChar :: Maybe Char}
deriving Show
defaultDelimStyle :: DelimStyle
defaultDelimStyle = DelimStyle { delimBegChar = Nothing
, delimSepChar = Nothing
, delimEndChar = Nothing }
data GroupStyle = GroupStyle { groupChr :: Maybe Char
, groupPos :: Maybe TopBottom }
deriving Show
defaultGroupStyle :: GroupStyle
defaultGroupStyle = GroupStyle {groupChr = Nothing, groupPos = Nothing}
type OMathRunStyle = [String]
data RunElem = TextRun String | LnBrk | Tab
deriving Show
data RunStyle = RunStyle { isBold :: Bool
, isItalic :: Bool
, isSmallCaps :: Bool
, isStrike :: Bool
, isSuperScript :: Bool
, isSubScript :: Bool
, underline :: Maybe String
, rStyle :: Maybe String }
deriving Show
defaultRunStyle :: RunStyle
defaultRunStyle = RunStyle { isBold = False
, isItalic = False
, isSmallCaps = False
, isStrike = False
, isSuperScript = False
, isSubScript = False
, underline = 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"
in
findElement (QName "blip" (Just a_ns) (Just "a")) element
>>= findAttr (QName "embed" (lookup "r" ns) (Just "r"))
>>= (\s -> Just $ Drawing s)
elemToDrawing _ _ = 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
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
elemToNAryStyle :: NameSpaces -> Element -> NAryStyle
elemToNAryStyle ns element
| Just narypr <- findChild (QName "naryPr" (lookup "m" ns) (Just "m")) element =
let
chr = findChild (QName "chr" (lookup "m" ns) (Just "m")) narypr >>=
findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
Just . head
limLoc = findChild (QName "limLoc" (lookup "m" ns) (Just "m")) narypr >>=
findAttr (QName "val" (lookup "m" ns) (Just "m"))
limLoc' = case limLoc of
Just "undOver" -> UnderOver
Just "subSup" -> SubSup
_ -> SubSup
in
NAryStyle { nAryChar = chr, nAryLimLoc = limLoc'}
elemToNAryStyle _ _ = defaultNAryStyle
elemToDelimStyle :: NameSpaces -> Element -> DelimStyle
elemToDelimStyle ns element
| Just dPr <- findChild (QName "dPr" (lookup "m" ns) (Just "m")) element =
let begChr = findChild (QName "begChr" (lookup "m" ns) (Just "m")) dPr >>=
findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
(\c -> if null c then Nothing else (Just $ head c))
sepChr = findChild (QName "sepChr" (lookup "m" ns) (Just "m")) dPr >>=
findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
(\c -> if null c then Nothing else (Just $ head c))
endChr = findChild (QName "endChr" (lookup "m" ns) (Just "m")) dPr >>=
findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
(\c -> if null c then Nothing else (Just $ head c))
in
DelimStyle { delimBegChar = begChr
, delimSepChar = sepChr
, delimEndChar = endChr}
elemToDelimStyle _ _ = defaultDelimStyle
elemToGroupStyle :: NameSpaces -> Element -> GroupStyle
elemToGroupStyle ns element
| Just gPr <- findChild (QName "groupChrPr" (lookup "m" ns) (Just "m")) element =
let chr = findChild (QName "chr" (lookup "m" ns) (Just "m")) gPr >>=
findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
Just . head
pos = findChild (QName "pos" (lookup "m" ns) (Just "m")) gPr >>=
findAttr (QName "val" (lookup "m" ns) (Just "m")) >>=
(\s -> Just $ if s == "top" then Top else Bottom)
in
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
elemToParPart :: NameSpaces -> Element -> Maybe 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
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
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
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
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
elemToParPart ns element
| qName (elName element) == "oMath" &&
qURI (elName element) == (lookup "m" ns) =
elemToMath ns element >>=
(\m -> Just $ PlainOMath m)
elemToParPart _ _ = Nothing
type Target = String
type Anchor = String
type BookMarkId = String
type RelId = String
type ChangeId = String
type Author = String
type ChangeDate = String