module Ideas.Text.MathML
( MathML(..), xml2mathml, mathml2xml
) where
import Data.Maybe
import Ideas.Text.XML
import Ideas.Utils.Uniplate hiding (children)
data MathML = MRow [MathML]
| MId String
| MNumber String
| MOperator String
| MString String
| MText String
| MSqrt MathML
| MRoot MathML MathML
| MSup MathML MathML
| MSub MathML MathML
| MSubSup MathML MathML MathML
| MFrac MathML MathML
| MFenced String String MathML
| MSpace
| MStyle
| MPadded
| MPhantom
| MError
| MEnclose
| MUnder
| MOver
| MUnderOver
| MTable
| MTableRow
| MLabeledTableRow
| MTableData
deriving (Show, Eq)
instance ToXML MathML where
toXML = mathml2xml
instance InXML MathML where
fromXML = either fail return . xml2mathml
instance Uniplate MathML where
uniplate math =
case math of
MRow xs -> plate MRow ||* xs
_ -> plate math
xml2mathml :: XML -> Either String MathML
xml2mathml = rec
where
rec xml = case name xml of
"mrow" -> MRow <$> mapM rec (children xml)
"mi" -> return (MId (getData xml))
"mn" -> return (MNumber (getData xml))
"mo" -> return (MOperator (getData xml))
"ms" -> return (MString (getData xml))
"mtext" -> return (MText (getData xml))
"mroot" -> case children xml of
[c, d] -> MRoot <$> rec c <*> rec d
_ -> fail "invalid mroot"
"msup" -> case children xml of
[c, d] -> MSup <$> rec c <*> rec d
_ -> fail "invalid msup"
"msub" -> case children xml of
[c, d] -> MSub <$> rec c <*> rec d
_ -> fail "invalid msub"
"msubsup" -> case children xml of
[c, d, e] -> MSubSup <$> rec c <*> rec d <*> rec e
_ -> fail "invalid msubsup"
"mfrac" -> case children xml of
[c, d] -> MFrac <$> rec c <*> rec d
_ -> fail "invalid mfrac"
"mfenced" -> case children xml of
[c] -> MFenced (fromMaybe "(" (findAttribute "open" xml)) (fromMaybe ")" (findAttribute "close" xml)) <$> rec c
_ -> fail "invalid mfenced"
"mspace" -> return MSpace
"mtable" -> return MTable
"mtr" -> return MTableRow
"mlabeledtr" -> return MLabeledTableRow
"munder" -> return MUnder
"mover" -> return MOver
"munderover" -> return MUnderOver
"math" -> impliedMRow xml
"msqrt" -> MSqrt <$> impliedMRow xml
"mphantom" -> return MPhantom
"mpadded" -> return MPadded
"mstyle" -> return MStyle
"merror" -> return MError
"mtd" -> return MTableData
"menclose" -> return MEnclose
_ -> fail ("unsupported MathML: " ++ show xml)
impliedMRow :: XML -> Either String MathML
impliedMRow xml =
case children xml of
[x] -> rec x
xs -> MRow <$> mapM rec xs
mathml2xml :: MathML -> XML
mathml2xml = makeXML "math" . rec
where
rec :: MathML -> XMLBuilder
rec math =
case math of
MRow ms -> element "mrow" (map rec ms)
MId s -> element "mi" [string s]
MNumber s -> element "mn" [string s]
MOperator s -> element "mo" [string s]
MString s -> element "ms" [string s]
MText s -> element "mtext" [string s]
MSqrt m -> element "msqrt" [rec m]
MRoot m1 m2 -> element "mroot" [rec m1, rec m2]
MSup m1 m2 -> element "msup" [rec m1, rec m2]
MSub m1 m2 -> element "msub" [rec m1, rec m2]
MSubSup m1 m2 m3 -> element "msubsup" [rec m1, rec m2, rec m3]
MFrac m1 m2 -> element "mfrac" [rec m1, rec m2]
MFenced s1 s2 m -> element "mfenced" ["open" .=. s1, "close" .=. s2, rec m]
MSpace -> element "mspace" []
MStyle -> element "mstyle" []
MPadded -> element "mpadded" []
MPhantom -> element "mphantom" []
MError -> element "merror" []
MEnclose -> element "menclose" []
MUnder -> element "munder" []
MOver -> element "mover" []
MUnderOver -> element "munderover" []
MTable -> element "mtable" []
MTableRow -> element "mtr" []
MLabeledTableRow -> element "mlabeledtr" []
MTableData -> element "mtd" []