module Text.TeXMath.MathMLWriter (toMathML, DisplayType(..), showExp)
where
import qualified Data.Map as M
import Text.XML.Light
import Text.TeXMath.Parser
import Data.Generics (everywhere, mkT)
data DisplayType = DisplayBlock
| DisplayInline
deriving Show
toMathML :: DisplayType -> [Exp] -> Element
toMathML dt exprs =
add_attr dtattr $ math $ map showExp $ everywhere (mkT $ handleDownup dt) exprs
where dtattr = Attr (unqual "display") dt'
dt' = case dt of
DisplayBlock -> "block"
DisplayInline -> "inline"
math :: [Element] -> Element
math = add_attr (Attr (unqual "xmlns") "http://www.w3.org/1998/Math/MathML") . unode "math" . unode "mrow"
mrow :: [Element] -> Element
mrow = unode "mrow"
unaryOps :: M.Map String String
unaryOps = M.fromList
[ ("\\sqrt", "msqrt")
, ("\\surd", "msqrt")
]
showUnary :: String -> Exp -> Element
showUnary c x =
case M.lookup c unaryOps of
Just c' -> unode c' (showExp x)
Nothing -> error $ "Unknown unary op: " ++ c
binaryOps :: M.Map String ([Element] -> Element)
binaryOps = M.fromList
[ ("\\frac", unode "mfrac")
, ("\\tfrac", withAttribute "displaystyle" "false" .
unode "mstyle" . unode "mfrac")
, ("\\dfrac", withAttribute "displaystyle" "true" .
unode "mstyle" . unode "mfrac")
, ("\\sqrt", unode "mroot")
, ("\\stackrel", unode "mover")
, ("\\overset", unode "mover")
, ("\\underset", unode "munder")
, ("\\binom", showBinom)
]
showBinom :: [Element] -> Element
showBinom lst = unode "mfenced" $ withAttribute "linethickness" "0" $ unode "mfrac" lst
showBinary :: String -> Exp -> Exp -> Element
showBinary c x y =
case M.lookup c binaryOps of
Just f -> f [showExp x, showExp y]
Nothing -> error $ "Unknown binary op: " ++ c
spaceWidth :: String -> Element
spaceWidth w = withAttribute "width" w $ unode "mspace" ()
makeStretchy :: Element -> Element
makeStretchy = withAttribute "stretchy" "true"
makeScaled :: String -> Element -> Element
makeScaled s = withAttribute "minsize" s . withAttribute "maxsize" s
makeText :: String -> String -> Element
makeText a s = if trailingSp
then mrow [s', sp]
else s'
where sp = spaceWidth "0.333em"
s' = withAttribute "mathvariant" a $ unode "mtext" s
trailingSp = not (null s) && last s `elem` " \t"
makeArray :: [Alignment] -> [ArrayLine] -> Element
makeArray as ls = unode "mtable" $
map (unode "mtr" .
zipWith (\a -> setAlignment a . unode "mtd". map showExp) as') ls
where setAlignment AlignLeft = withAttribute "columnalign" "left"
setAlignment AlignRight = withAttribute "columnalign" "right"
setAlignment AlignCenter = withAttribute "columnalign" "center"
setAlignment AlignDefault = id
as' = as ++ cycle [AlignDefault]
withAttribute :: String -> String -> Element -> Element
withAttribute a = add_attr . Attr (unqual a)
accent :: String -> Element
accent = add_attr (Attr (unqual "accent") "true") .
unode "mo"
handleDownup :: DisplayType -> Exp -> Exp
handleDownup DisplayInline (EDown x y) = ESub x y
handleDownup DisplayBlock (EDown x y) = EUnder x y
handleDownup DisplayInline (EUp x y) = ESuper x y
handleDownup DisplayBlock (EUp x y) = EOver x y
handleDownup DisplayInline (EDownup x y z) = ESubsup x y z
handleDownup DisplayBlock (EDownup x y z) = EUnderover x y z
handleDownup _ x = x
showExp :: Exp -> Element
showExp e =
case e of
ENumber x -> unode "mn" x
EGrouped [x] -> showExp x
EGrouped xs -> mrow $ map showExp xs
EIdentifier x -> unode "mi" x
EMathOperator x -> unode "mi" x
ESymbol Accent x -> accent x
EStretchy (ESymbol Open x) -> makeStretchy $ unode "mo" x
EStretchy (ESymbol Close x) -> makeStretchy $ unode "mo" x
ESymbol Open x -> withAttribute "stretchy" "false" $ unode "mo" x
ESymbol Close x -> withAttribute "stretchy" "false" $ unode "mo" x
ESymbol _ x -> unode "mo" x
ESpace x -> spaceWidth x
EBinary c x y -> showBinary c x y
ESub x y -> unode "msub" $ map showExp [x, y]
ESuper x y -> unode "msup" $ map showExp [x, y]
ESubsup x y z -> unode "msubsup" $ map showExp [x, y, z]
EUnder x y -> unode "munder" $ map showExp [x, y]
EOver x y -> unode "mover" $ map showExp [x, y]
EUnderover x y z -> unode "munderover" $ map showExp [x, y, z]
EUnary c x -> showUnary c x
EStretchy x -> makeStretchy $ showExp x
EScaled s x -> makeScaled s $ showExp x
EArray as ls -> makeArray as ls
EText a s -> makeText a s
x -> error $ "showExp encountered " ++ show x