{-# LANGUAGE ViewPatterns, ScopedTypeVariables, OverloadedStrings,
   TupleSections #-}
{-
Copyright (C) 2009 John MacFarlane <jgm@berkeley.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
-}

{- | Functions for writing a parsed formula as MathML.
-}

module Text.TeXMath.Writers.MathML (writeMathML)
where

import Text.XML.Light
import Text.TeXMath.Types
import Text.TeXMath.Unicode.ToUnicode
import Data.Generics (everywhere, mkT)
import Text.TeXMath.Shared (getMMLType, handleDownup)
import Text.TeXMath.Readers.MathML.MMLDict (getMathMLOperator)
import qualified Data.Text as T
import Text.Printf

-- | Transforms an expression tree to a MathML XML tree
writeMathML :: DisplayType -> [Exp] -> Element
writeMathML :: DisplayType -> [Exp] -> Element
writeMathML DisplayType
dt [Exp]
exprs =
  Attr -> Element -> Element
add_attr Attr
dtattr forall a b. (a -> b) -> a -> b
$ Element -> Element
math forall a b. (a -> b) -> a -> b
$ Maybe TextType -> Exp -> Element
showExp forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
EGrouped
  forall a b. (a -> b) -> a -> b
$ (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere (forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT forall a b. (a -> b) -> a -> b
$ DisplayType -> Exp -> Exp
handleDownup DisplayType
dt) [Exp]
exprs
    where dtattr :: Attr
dtattr = QName -> String -> Attr
Attr (String -> QName
unqual String
"display") String
dt'
          dt' :: String
dt' =  case DisplayType
dt of
                      DisplayType
DisplayBlock  -> String
"block"
                      DisplayType
DisplayInline -> String
"inline"

math :: Element -> Element
math :: Element -> Element
math = Attr -> Element -> Element
add_attr (QName -> String -> Attr
Attr (String -> QName
unqual String
"xmlns") String
"http://www.w3.org/1998/Math/MathML") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Node t => String -> t -> Element
unode String
"math"

mrow :: [Element] -> Element
mrow :: [Element] -> Element
mrow = forall t. Node t => String -> t -> Element
unode String
"mrow"

showFraction :: Maybe TextType -> FractionType -> Exp -> Exp -> Element
showFraction :: Maybe TextType -> FractionType -> Exp -> Exp -> Element
showFraction Maybe TextType
tt FractionType
ft Exp
x Exp
y =
  case FractionType
ft of
       FractionType
NormalFrac   -> forall t. Node t => String -> t -> Element
unode String
"mfrac" [Element
x', Element
y']
       FractionType
InlineFrac   -> String -> Text -> Element -> Element
withAttribute String
"displaystyle" Text
"false" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                         forall t. Node t => String -> t -> Element
unode String
"mfrac" forall a b. (a -> b) -> a -> b
$ [Element
x', Element
y']
       FractionType
DisplayFrac  -> String -> Text -> Element -> Element
withAttribute String
"displaystyle" Text
"true" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                         forall t. Node t => String -> t -> Element
unode String
"mfrac" forall a b. (a -> b) -> a -> b
$ [Element
x', Element
y']
       FractionType
NoLineFrac   -> String -> Text -> Element -> Element
withAttribute String
"linethickness" Text
"0" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                         forall t. Node t => String -> t -> Element
unode String
"mfrac" forall a b. (a -> b) -> a -> b
$ [Element
x', Element
y']
  where x' :: Element
x' = Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt Exp
x
        y' :: Element
y' = Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt Exp
y

spaceWidth :: Rational -> Element
spaceWidth :: Rational -> Element
spaceWidth Rational
w =
  String -> Text -> Element -> Element
withAttribute String
"width" (Text -> Text
dropTrailing0s
     (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"%.3f" (forall a. Fractional a => Rational -> a
fromRational Rational
w :: Double)) forall a. Semigroup a => a -> a -> a
<> Text
"em") forall a b. (a -> b) -> a -> b
$ forall t. Node t => String -> t -> Element
unode String
"mspace" ()

makeStretchy :: FormType -> Element -> Element
makeStretchy :: FormType -> Element -> Element
makeStretchy (FormType -> Text
fromForm -> Text
t)  = String -> Text -> Element -> Element
withAttribute String
"stretchy" Text
"true"
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> Element -> Element
withAttribute String
"form" Text
t

fromForm :: FormType -> T.Text
fromForm :: FormType -> Text
fromForm FormType
FInfix   = Text
"infix"
fromForm FormType
FPostfix = Text
"postfix"
fromForm FormType
FPrefix  = Text
"prefix"

makeScaled :: Rational -> Element -> Element
makeScaled :: Rational -> Element -> Element
makeScaled Rational
x = String -> Text -> Element -> Element
withAttribute String
"minsize" Text
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> Element -> Element
withAttribute String
"maxsize" Text
s
  where s :: Text
s = Text -> Text
dropTrailing0s forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf String
"%.3f" (forall a. Fractional a => Rational -> a
fromRational Rational
x :: Double)


dropTrailing0s :: T.Text -> T.Text
dropTrailing0s :: Text -> Text
dropTrailing0s Text
t = case Text -> Maybe (Text, Char)
T.unsnoc Text
t of -- T.spanEnd does not exist
  Just (Text
ts, Char
'0') -> Text -> Text
addZero forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhileEnd (forall a. Eq a => a -> a -> Bool
== Char
'0') Text
ts
  Maybe (Text, Char)
_              -> Text
t
  where
    addZero :: Text -> Text
addZero Text
x = case Text -> Maybe (Text, Char)
T.unsnoc Text
x of
      Just (Text
_, Char
'.') -> Text -> Char -> Text
T.snoc Text
x Char
'0'
      Maybe (Text, Char)
_ -> Text
x

-- Note: Converts strings to unicode directly, as few renderers support those mathvariants.
makeText :: TextType -> T.Text -> Element
makeText :: TextType -> Text -> Element
makeText TextType
a Text
s = case (Bool
leadingSp, Bool
trailingSp) of
                   (Bool
False, Bool
False) -> Element
s'
                   (Bool
True,  Bool
False) -> [Element] -> Element
mrow [Element
sp, Element
s']
                   (Bool
False, Bool
True)  -> [Element] -> Element
mrow [Element
s', Element
sp]
                   (Bool
True,  Bool
True)  -> [Element] -> Element
mrow [Element
sp, Element
s', Element
sp]
  where sp :: Element
sp = Rational -> Element
spaceWidth (Rational
1forall a. Fractional a => a -> a -> a
/Rational
3)
        s' :: Element
s' = String -> Text -> Element -> Element
withAttribute String
"mathvariant" Text
attr forall a b. (a -> b) -> a -> b
$ String -> Text -> Element
tunode String
"mtext" forall a b. (a -> b) -> a -> b
$ TextType -> Text -> Text
toUnicode TextType
a Text
s
        trailingSp :: Bool
trailingSp = case Text -> Maybe (Text, Char)
T.unsnoc Text
s of
          Just (Text
_, Char
c) -> (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
c) Text
" \t"
          Maybe (Text, Char)
_           -> Bool
False
        leadingSp :: Bool
leadingSp  = case Text -> Maybe (Char, Text)
T.uncons Text
s of
          Just (Char
c, Text
_) -> (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
c) Text
" \t"
          Maybe (Char, Text)
_           -> Bool
False
        attr :: Text
attr = TextType -> Text
getMMLType TextType
a

makeArray :: Maybe TextType -> [Alignment] -> [ArrayLine] -> Element
makeArray :: Maybe TextType -> [Alignment] -> [ArrayLine] -> Element
makeArray Maybe TextType
tt [Alignment]
as [ArrayLine]
ls = forall t. Node t => String -> t -> Element
unode String
"mtable" forall a b. (a -> b) -> a -> b
$
  forall a b. (a -> b) -> [a] -> [b]
map (forall t. Node t => String -> t -> Element
unode String
"mtr" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Alignment
a -> Alignment -> Element -> Element
setAlignment Alignment
a forall b c a. (b -> c) -> (a -> b) -> a -> c
.  forall t. Node t => String -> t -> Element
unode String
"mtd"forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt)) [Alignment]
as') [ArrayLine]
ls
   -- see #205 on the need for style attributes:
   where setAlignment :: Alignment -> Element -> Element
setAlignment Alignment
AlignLeft    =
           String -> Text -> Element -> Element
withAttribute String
"columnalign" Text
"left" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           String -> Text -> Element -> Element
withAttribute String
"style" Text
"text-align: left"
         setAlignment Alignment
AlignRight   =
           String -> Text -> Element -> Element
withAttribute String
"columnalign" Text
"right" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           String -> Text -> Element -> Element
withAttribute String
"style" Text
"text-align: right"
         setAlignment Alignment
AlignCenter  =
           String -> Text -> Element -> Element
withAttribute String
"columnalign" Text
"center" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           String -> Text -> Element -> Element
withAttribute String
"style" Text
"text-align: center"
         as' :: [Alignment]
as'                       = [Alignment]
as forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
cycle [Alignment
AlignCenter]

-- Kept as String for Text.XML.Light
withAttribute :: String -> T.Text -> Element -> Element
withAttribute :: String -> Text -> Element -> Element
withAttribute String
a = Attr -> Element -> Element
add_attr forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> String -> Attr
Attr (String -> QName
unqual String
a) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

accent :: T.Text -> Element
accent :: Text -> Element
accent = Attr -> Element -> Element
add_attr (QName -> String -> Attr
Attr (String -> QName
unqual String
"accent") String
"true") forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           String -> Text -> Element
tunode String
"mo"

makeFence :: FormType -> Element -> Element
makeFence :: FormType -> Element -> Element
makeFence (FormType -> Text
fromForm -> Text
t) = String -> Text -> Element -> Element
withAttribute String
"stretchy" Text
"false" forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> Element -> Element
withAttribute String
"form" Text
t

showExp' :: Maybe TextType -> Exp -> Element
showExp' :: Maybe TextType -> Exp -> Element
showExp' Maybe TextType
tt Exp
e =
  case Exp
e of
    ESymbol TeXSymbolType
Accent Text
x -> Text -> Element
accent Text
x
    ESymbol TeXSymbolType
_ Text
x      ->
      let isaccent :: Text
isaccent = case (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Text
"accent") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Operator -> [Text]
properties forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                           Text -> FormType -> Maybe Operator
getMathMLOperator Text
x FormType
FPostfix of
                             Just Bool
True -> Text
"true"
                             Maybe Bool
_         -> Text
"false"
      in  String -> Text -> Element -> Element
withAttribute String
"accent" Text
isaccent forall a b. (a -> b) -> a -> b
$ String -> Text -> Element
tunode String
"mo" Text
x
    Exp
_                -> Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt Exp
e

showExp :: Maybe TextType -> Exp -> Element
showExp :: Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt Exp
e =
 let toUnicodeMaybe :: TextType -> T.Text -> Maybe T.Text
     toUnicodeMaybe :: TextType -> Text -> Maybe Text
toUnicodeMaybe TextType
textStyle Text
t =
       String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((TextType, Char) -> Maybe Char
toUnicodeChar forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextType
textStyle,)) (Text -> String
T.unpack Text
t)
     -- variant node: tries to convert text to appropriate unicode
     -- characters depending on style
     vnode :: String -> T.Text -> Element
     vnode :: String -> Text -> Element
vnode String
elname Text
t
       = case Maybe TextType
tt of
           Maybe TextType
Nothing -> String -> Text -> Element
tunode String
elname Text
t
           Just TextType
TextNormal -> String -> Text -> Element -> Element
withAttribute String
"mathvariant" Text
"normal" forall a b. (a -> b) -> a -> b
$
                                String -> Text -> Element
tunode String
elname Text
t
           Just TextType
textStyle ->
             case TextType -> Text -> Maybe Text
toUnicodeMaybe TextType
textStyle Text
t of
               -- if we can't find unicode equivalents, rely on mathvariant:
               Maybe Text
Nothing -> String -> Text -> Element -> Element
withAttribute String
"mathvariant" (TextType -> Text
getMMLType TextType
textStyle) forall a b. (a -> b) -> a -> b
$
                             String -> Text -> Element
tunode String
elname Text
t
               Just Text
t' -> String -> Text -> Element
tunode String
elname Text
t'
  in case Exp
e of
   ENumber Text
x        -> String -> Text -> Element
vnode String
"mn" Text
x
   EGrouped [Exp
x]     -> Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt Exp
x
   EGrouped [Exp]
xs      -> [Element] -> Element
mrow forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt) [Exp]
xs
   EDelimited Text
start Text
end [InEDelimited]
xs -> [Element] -> Element
mrow forall a b. (a -> b) -> a -> b
$
     [ FormType -> Element -> Element
makeStretchy FormType
FPrefix (String -> Text -> Element
vnode String
"mo" Text
start) | Bool -> Bool
not (Text -> Bool
T.null Text
start) ] forall a. [a] -> [a] -> [a]
++
     forall a b. (a -> b) -> [a] -> [b]
map (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FormType -> Element -> Element
makeStretchy FormType
FInfix forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text -> Element
vnode String
"mo") (Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt)) [InEDelimited]
xs forall a. [a] -> [a] -> [a]
++
     [ FormType -> Element -> Element
makeStretchy FormType
FPostfix (String -> Text -> Element
vnode String
"mo" Text
end)
        | Bool -> Bool
not (Text -> Bool
T.null Text
end) ]
   EIdentifier Text
x    -> String -> Text -> Element
vnode String
"mi" Text
x
   EMathOperator Text
x  -> String -> Text -> Element
vnode String
"mo" Text
x
   ESymbol TeXSymbolType
Open Text
x   -> FormType -> Element -> Element
makeFence FormType
FPrefix forall a b. (a -> b) -> a -> b
$ String -> Text -> Element
vnode String
"mo" Text
x
   ESymbol TeXSymbolType
Close Text
x  -> FormType -> Element -> Element
makeFence FormType
FPostfix forall a b. (a -> b) -> a -> b
$ String -> Text -> Element
vnode String
"mo" Text
x
   ESymbol TeXSymbolType
Ord Text
x    -> String -> Text -> Element
vnode String
"mi" Text
x
   ESymbol TeXSymbolType
_ Text
x      -> String -> Text -> Element
vnode String
"mo" Text
x
   ESpace Rational
x         -> Rational -> Element
spaceWidth Rational
x
   EFraction FractionType
ft Exp
x Exp
y -> Maybe TextType -> FractionType -> Exp -> Exp -> Element
showFraction Maybe TextType
tt FractionType
ft Exp
x Exp
y
   ESub Exp
x Exp
y         -> forall t. Node t => String -> t -> Element
unode String
"msub" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt) [Exp
x, Exp
y]
   ESuper Exp
x Exp
y       -> forall t. Node t => String -> t -> Element
unode String
"msup" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt) [Exp
x, Exp
y]
   ESubsup Exp
x Exp
y Exp
z    -> forall t. Node t => String -> t -> Element
unode String
"msubsup" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt) [Exp
x, Exp
y, Exp
z]
   EUnder Bool
_ Exp
x Exp
y     -> forall t. Node t => String -> t -> Element
unode String
"munder" [Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt Exp
x, Maybe TextType -> Exp -> Element
showExp' Maybe TextType
tt Exp
y]
   EOver Bool
_ Exp
x Exp
y      -> forall t. Node t => String -> t -> Element
unode String
"mover" [Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt Exp
x, Maybe TextType -> Exp -> Element
showExp' Maybe TextType
tt Exp
y]
   EUnderover Bool
_ Exp
x Exp
y Exp
z -> forall t. Node t => String -> t -> Element
unode String
"munderover"
                          [Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt Exp
x, Maybe TextType -> Exp -> Element
showExp' Maybe TextType
tt Exp
y, Maybe TextType -> Exp -> Element
showExp' Maybe TextType
tt Exp
z]
   EPhantom Exp
x       -> forall t. Node t => String -> t -> Element
unode String
"mphantom" forall a b. (a -> b) -> a -> b
$ Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt Exp
x
   EBoxed Exp
x         -> String -> Text -> Element -> Element
withAttribute String
"notation" Text
"box" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       forall t. Node t => String -> t -> Element
unode String
"menclose" forall a b. (a -> b) -> a -> b
$ Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt Exp
x
   ESqrt Exp
x          -> forall t. Node t => String -> t -> Element
unode String
"msqrt" forall a b. (a -> b) -> a -> b
$ Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt Exp
x
   ERoot Exp
i Exp
x        -> forall t. Node t => String -> t -> Element
unode String
"mroot" [Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt Exp
x, Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt Exp
i]
   EScaled Rational
s Exp
x      -> Rational -> Element -> Element
makeScaled Rational
s forall a b. (a -> b) -> a -> b
$ Maybe TextType -> Exp -> Element
showExp Maybe TextType
tt Exp
x
   EArray [Alignment]
as [ArrayLine]
ls     -> Maybe TextType -> [Alignment] -> [ArrayLine] -> Element
makeArray Maybe TextType
tt [Alignment]
as [ArrayLine]
ls
   EText TextType
a Text
s        -> case (Maybe TextType
tt, TextType
a) of
                         (Just TextType
ty, TextType
TextNormal) -> TextType -> Text -> Element
makeText TextType
ty Text
s
                         (Maybe TextType, TextType)
_ -> TextType -> Text -> Element
makeText TextType
a Text
s
   EStyled TextType
a [Exp]
es     -> Maybe TextType -> Exp -> Element
showExp (forall a. a -> Maybe a
Just TextType
a) ([Exp] -> Exp
EGrouped [Exp]
es)
   -- see https://developer.mozilla.org/en-US/docs/Web/MathML/Element/mstyle
   -- Historically, this element accepted almost all the MathML attributes and
   -- it was used to override the default attribute values of its descendants.
   -- It was later restricted to only a few relevant styling attributes that
   -- were used in existing web pages. Nowadays, these styling attributes are
   -- common to all MathML elements and so <mstyle> is really just equivalent
   -- to an <mrow> element. However, <mstyle> may still be relevant for
   -- compatibility with MathML implementations outside browsers.

-- Kept as String for Text.XML.Light
tunode :: String -> T.Text -> Element
tunode :: String -> Text -> Element
tunode String
s = forall t. Node t => String -> t -> Element
unode String
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack