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