1{-# LANGUAGE ViewPatterns, ScopedTypeVariables, OverloadedStrings #-} 2{- 3Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu> 4 5This program is free software; you can redistribute it and/or modify 6it under the terms of the GNU General Public License as published by 7the Free Software Foundation; either version 2 of the License, or 8(at your option) any later version. 9 10This program is distributed in the hope that it will be useful, 11but WITHOUT ANY WARRANTY; without even the implied warranty of 12MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13GNU General Public License for more details. 14 15You should have received a copy of the GNU General Public License 16along with this program; if not, write to the Free Software 17Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 18-} 19 20{- | Functions for writing a parsed formula as MathML. 21-} 22 23module Text.TeXMath.Writers.MathML (writeMathML) 24where 25 26import Text.XML.Light 27import Text.TeXMath.Types 28import Text.TeXMath.Unicode.ToUnicode 29import Data.Generics (everywhere, mkT) 30import Text.TeXMath.Shared (getMMLType, handleDownup) 31import Text.TeXMath.Readers.MathML.MMLDict (getMathMLOperator) 32import Control.Applicative ((<$>)) 33import Data.Semigroup ((<>)) 34import qualified Data.Text as T 35import Text.Printf 36 37-- | Transforms an expression tree to a MathML XML tree 38writeMathML :: DisplayType -> [Exp] -> Element 39writeMathML dt exprs = 40 add_attr dtattr $ math $ showExp TextNormal $ EGrouped 41 $ everywhere (mkT $ handleDownup dt) exprs 42 where dtattr = Attr (unqual "display") dt' 43 dt' = case dt of 44 DisplayBlock -> "block" 45 DisplayInline -> "inline" 46 47math :: Element -> Element 48math = add_attr (Attr (unqual "xmlns") "http://www.w3.org/1998/Math/MathML") . unode "math" 49 50mrow :: [Element] -> Element 51mrow = unode "mrow" 52 53showFraction :: TextType -> FractionType -> Exp -> Exp -> Element 54showFraction tt ft x y = 55 case ft of 56 NormalFrac -> unode "mfrac" [x', y'] 57 InlineFrac -> withAttribute "displaystyle" "false" . 58 unode "mstyle" . unode "mfrac" $ [x', y'] 59 DisplayFrac -> withAttribute "displaystyle" "true" . 60 unode "mstyle" . unode "mfrac" $ [x', y'] 61 NoLineFrac -> withAttribute "linethickness" "0" . 62 unode "mfrac" $ [x', y'] 63 where x' = showExp tt x 64 y' = showExp tt y 65 66spaceWidth :: Rational -> Element 67spaceWidth w = 68 withAttribute "width" (dropTrailing0s 69 (T.pack $ printf "%.3f" (fromRational w :: Double)) <> "em") $ unode "mspace" () 70 71makeStretchy :: FormType -> Element -> Element 72makeStretchy (fromForm -> t) = withAttribute "stretchy" "true" 73 . withAttribute "form" t 74 75fromForm :: FormType -> T.Text 76fromForm FInfix = "infix" 77fromForm FPostfix = "postfix" 78fromForm FPrefix = "prefix" 79 80makeScaled :: Rational -> Element -> Element 81makeScaled x = withAttribute "minsize" s . withAttribute "maxsize" s 82 where s = dropTrailing0s $ T.pack $ printf "%.3f" (fromRational x :: Double) 83 84 85dropTrailing0s :: T.Text -> T.Text 86dropTrailing0s t = case T.unsnoc t of -- T.spanEnd does not exist 87 Just (ts, '0') -> addZero $ T.dropWhileEnd (== '0') ts 88 _ -> t 89 where 90 addZero x = case T.unsnoc x of 91 Just (_, '.') -> T.snoc x '0' 92 _ -> x 93 94makeStyled :: TextType -> [Element] -> Element 95makeStyled a es = withAttribute "mathvariant" attr 96 $ unode "mstyle" es 97 where attr = getMMLType a 98 99-- Note: Converts strings to unicode directly, as few renderers support those mathvariants. 100makeText :: TextType -> T.Text -> Element 101makeText a s = case (leadingSp, trailingSp) of 102 (False, False) -> s' 103 (True, False) -> mrow [sp, s'] 104 (False, True) -> mrow [s', sp] 105 (True, True) -> mrow [sp, s', sp] 106 where sp = spaceWidth (1/3) 107 s' = withAttribute "mathvariant" attr $ tunode "mtext" $ toUnicode a s 108 trailingSp = case T.unsnoc s of 109 Just (_, c) -> T.any (== c) " \t" 110 _ -> False 111 leadingSp = case T.uncons s of 112 Just (c, _) -> T.any (== c) " \t" 113 _ -> False 114 attr = getMMLType a 115 116makeArray :: TextType -> [Alignment] -> [ArrayLine] -> Element 117makeArray tt as ls = unode "mtable" $ 118 map (unode "mtr" . 119 zipWith (\a -> setAlignment a . unode "mtd". map (showExp tt)) as') ls 120 where setAlignment AlignLeft = withAttribute "columnalign" "left" 121 setAlignment AlignRight = withAttribute "columnalign" "right" 122 setAlignment AlignCenter = withAttribute "columnalign" "center" 123 as' = as ++ cycle [AlignCenter] 124 125-- Kept as String for Text.XML.Light 126withAttribute :: String -> T.Text -> Element -> Element 127withAttribute a = add_attr . Attr (unqual a) . T.unpack 128 129accent :: T.Text -> Element 130accent = add_attr (Attr (unqual "accent") "true") . 131 tunode "mo" 132 133makeFence :: FormType -> Element -> Element 134makeFence (fromForm -> t) = withAttribute "stretchy" "false" . withAttribute "form" t 135 136showExp' :: TextType -> Exp -> Element 137showExp' tt e = 138 case e of 139 ESymbol Accent x -> accent x 140 ESymbol _ x -> 141 let isaccent = case (elem "accent") . properties <$> 142 getMathMLOperator x FPostfix of 143 Just True -> "true" 144 _ -> "false" 145 in withAttribute "accent" isaccent $ tunode "mo" x 146 _ -> showExp tt e 147 148showExp :: TextType -> Exp -> Element 149showExp tt e = 150 case e of 151 ENumber x -> tunode "mn" x 152 EGrouped [x] -> showExp tt x 153 EGrouped xs -> mrow $ map (showExp tt) xs 154 EDelimited start end xs -> mrow $ 155 [ makeStretchy FPrefix (tunode "mo" start) | not (T.null start) ] ++ 156 map (either (makeStretchy FInfix . tunode "mo") (showExp tt)) xs ++ 157 [ makeStretchy FPostfix (tunode "mo" end) | not (T.null end) ] 158 EIdentifier x -> tunode "mi" $ toUnicode tt x 159 EMathOperator x -> tunode "mo" x 160 ESymbol Open x -> makeFence FPrefix $ tunode "mo" x 161 ESymbol Close x -> makeFence FPostfix $ tunode "mo" x 162 ESymbol Ord x -> tunode "mi" x 163 ESymbol _ x -> tunode "mo" x 164 ESpace x -> spaceWidth x 165 EFraction ft x y -> showFraction tt ft x y 166 ESub x y -> unode "msub" $ map (showExp tt) [x, y] 167 ESuper x y -> unode "msup" $ map (showExp tt) [x, y] 168 ESubsup x y z -> unode "msubsup" $ map (showExp tt) [x, y, z] 169 EUnder _ x y -> unode "munder" [showExp tt x, showExp' tt y] 170 EOver _ x y -> unode "mover" [showExp tt x, showExp' tt y] 171 EUnderover _ x y z -> unode "munderover" 172 [showExp tt x, showExp' tt y, showExp' tt z] 173 EPhantom x -> unode "mphantom" $ showExp tt x 174 EBoxed x -> withAttribute "notation" "box" . 175 unode "menclose" $ showExp tt x 176 ESqrt x -> unode "msqrt" $ showExp tt x 177 ERoot i x -> unode "mroot" [showExp tt x, showExp tt i] 178 EScaled s x -> makeScaled s $ showExp tt x 179 EArray as ls -> makeArray tt as ls 180 EText a s -> makeText a s 181 EStyled a es -> makeStyled a $ map (showExp a) es 182 183-- Kept as String for Text.XML.Light 184tunode :: String -> T.Text -> Element 185tunode s = unode s . T.unpack 186