content: {-# 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,
                              isUppercaseGreek, isRLSequence)
  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 dt exprs =
    add_attr dtattr $ math $ showExp Nothing $ EGrouped
    $ 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"
  
  mrow :: [Element] -> Element
  mrow = unode "mrow"
  
  showFraction :: Maybe TextType -> FractionType -> Exp -> Exp -> Element
  showFraction tt ft x y =
    case ft of
         NormalFrac   -> unode "mfrac" [x', y']
         InlineFrac   -> withAttribute "displaystyle" "false" .
                           unode "mstyle" .
                           unode "mfrac" $ [x', y']
         DisplayFrac  -> withAttribute "displaystyle" "true" .
                           unode "mstyle" .
                           unode "mfrac" $ [x', y']
         NoLineFrac   -> withAttribute "linethickness" "0" .
                           unode "mfrac" $ [x', y']
    where x' = showExp tt x
          y' = showExp tt y
  
  spaceWidth :: Rational -> Element
  spaceWidth w =
    withAttribute "width" (dropTrailing0s
       (T.pack $ printf "%.3f" (fromRational w :: Double)) <> "em") $ unode "mspace" ()
  
  makeStretchy :: FormType -> Element -> Element
  makeStretchy (fromForm -> t)  = withAttribute "stretchy" "true"
                                  . withAttribute "form" t
  
  fromForm :: FormType -> T.Text
  fromForm FInfix   = "infix"
  fromForm FPostfix = "postfix"
  fromForm FPrefix  = "prefix"
  
  makeScaled :: Rational -> Element -> Element
  makeScaled x = withAttribute "minsize" p . withAttribute "maxsize" p 
                 . setAttribute "stretchy" "true"
    where p = T.pack $ printf "%d%%" (round (100*x) :: Int)
  
  
  dropTrailing0s :: T.Text -> T.Text
  dropTrailing0s t = case T.unsnoc t of -- T.spanEnd does not exist
    Just (ts, '0') -> addZero $ T.dropWhileEnd (== '0') ts
    _              -> t
    where
      addZero x = case T.unsnoc x of
        Just (_, '.') -> T.snoc x '0'
        _ -> x
  
  -- Note: Converts strings to unicode directly, as few renderers support those mathvariants.
  makeText :: TextType -> T.Text -> Element
  makeText a s = case (leadingSp, trailingSp) of
                     (False, False) -> s'
                     (True,  False) -> mrow [sp, s']
                     (False, True)  -> mrow [s', sp]
                     (True,  True)  -> mrow [sp, s', sp]
    where sp = spaceWidth (1/3)
          s' = withAttribute "mathvariant" attr $ tunode "mtext" $ toUnicode a s
          trailingSp = case T.unsnoc s of
            Just (_, c) -> T.any (== c) " \t"
            _           -> False
          leadingSp  = case T.uncons s of
            Just (c, _) -> T.any (== c) " \t"
            _           -> False
          attr = getMMLType a
  
  makeArray :: Maybe TextType -> [Alignment] -> [ArrayLine] -> Element
  makeArray tt as ls = unode "mtable" $
    map (unode "mtr" .
      zipWith (\a -> setAlignment a .  unode "mtd". showExps tt) as') ls
     -- see #205 on the need for style attributes:
     where setAlignment AlignLeft    =
             withAttribute "columnalign" "left" .
             withAttribute "style"
               (if isRLSequence as
                   then "text-align: left; padding-left: 0"
                   else "text-align: left")
           setAlignment AlignRight   =
             withAttribute "columnalign" "right" .
             withAttribute "style"
               (if isRLSequence as
                   then "text-align: right; padding-right: 0"
                   else "text-align: right")
           setAlignment AlignCenter  =
             withAttribute "columnalign" "center" .
             withAttribute "style" "text-align: center"
           as'                       = as ++ repeat AlignCenter
  
  -- Kept as String for Text.XML.Light
  withAttribute :: String -> T.Text -> Element -> Element
  withAttribute a = add_attr . Attr (unqual a) . T.unpack
  
  -- Preserves the order of any existing attributes
  setAttribute :: String -> T.Text -> Element -> Element
  setAttribute a v e = e { elAttribs = update (elAttribs e) }
    where
      newAttr = Attr (unqual a) (T.unpack v)
      update [] = [newAttr]
      update (x:xs)
          | qName (attrKey x) == a = 
              newAttr : xs
          | otherwise = 
              x : update xs
              
  accent :: T.Text -> Element
  accent = add_attr (Attr (unqual "accent") "true") .
             tunode "mo"
  
  makeFence :: FormType -> Element -> Element
  makeFence (fromForm -> t) = withAttribute "stretchy" "false" . withAttribute "form" t
  
  showExp' :: Maybe TextType -> Exp -> Element
  showExp' tt e =
    case e of
      ESymbol Accent x -> accent x
      ESymbol _ x      ->
        let isaccent = case (elem "accent") . properties <$>
                             getMathMLOperator x FPostfix of
                               Just True -> "true"
                               _         -> "false"
        in  withAttribute "accent" isaccent $ tunode "mo" x
      _                -> showExp tt e
  
  showExps :: Maybe TextType -> [Exp] -> [Element]
  showExps tt = map (showExp tt) . insertFunctionApps
  
  insertFunctionApps :: [Exp] -> [Exp]
  -- handle this as a special case, or we get an infinite loop
  -- since we insert a new EGrouped to which insertFunctionApp will be applied.
  insertFunctionApps [e@EMathOperator{}, ESymbol _ "\x2061"] =
    [e, ESymbol Pun "\x2061"]
  insertFunctionApps es' = go es'
   where
    go [] = []
    go (e@EMathOperator{} : ESymbol _ "\x2061" : es) =
      EGrouped [e , ESymbol Pun "\x2061"] : go es
    go (e@EMathOperator{} : es@(_:_)) =
      EGrouped [e, ESymbol Pun "\x2061"] : go es
    go (e:es) = e : go es
  
  showExp :: Maybe TextType -> Exp -> Element
  showExp tt e =
   let toUnicodeMaybe :: TextType -> T.Text -> Maybe T.Text
       toUnicodeMaybe textStyle t =
         T.pack <$> mapM (toUnicodeChar . (textStyle,)) (T.unpack t)
       -- variant node: tries to convert text to appropriate unicode
       -- characters depending on style
       vnode :: String -> T.Text -> Element
       vnode elname t
         = case tt of
             Nothing ->
               if isUppercaseGreek t -- see #255
                  then withAttribute "mathvariant" "normal" $ tunode elname t
                  else tunode elname t
             Just TextNormal -> withAttribute "mathvariant" "normal" $
                                  tunode elname t
             Just textStyle ->
               case toUnicodeMaybe textStyle t of
                 -- if we can't find unicode equivalents, rely on mathvariant:
                 Nothing -> withAttribute "mathvariant" (getMMLType textStyle) $
                               tunode elname t
                 Just t' -> tunode elname t'
    in case e of
     ENumber x        -> vnode "mn" x
     EGrouped [x]     -> showExp tt x
     EGrouped xs      -> mrow $ showExps tt xs
     EDelimited start end xs -> mrow $
       [ makeStretchy FPrefix (vnode "mo" start) | not (T.null start) ] ++
       map (either (makeStretchy FInfix . vnode "mo") (showExp tt)) xs ++
       [ makeStretchy FPostfix (vnode "mo" end)
          | not (T.null end) ]
     EIdentifier x    -> vnode "mi" x
     EMathOperator x  -> -- see #257, #270
       case tt of
         Nothing -> withAttribute "mathvariant" "normal" $ tunode "mi" x
         _ -> vnode "mi" x
     ESymbol Open x   -> makeFence FPrefix $ vnode "mo" x
     ESymbol Close x  -> makeFence FPostfix $ vnode "mo" x
     ESymbol Ord x
       | x == "\x2061" -> vnode "mo" x
       | otherwise    -> vnode "mi" x
     ESymbol _ x      -> vnode "mo" x
     ESpace x         -> spaceWidth x
     EFraction ft x y -> showFraction tt ft x y
     ESub x y         -> unode "msub" $ showExps tt [x, y]
     ESuper x y       -> unode "msup" $ showExps tt [x, y]
     ESubsup x y z    -> unode "msubsup" $ showExps tt [x, y, z]
     EUnder _ x y     -> unode "munder" $ showExps tt [x] ++ [showExp' tt y]
     EOver _ x (ESymbol Accent "\8407") -- see #218, gives better rendering for vectors
                      -> unode "mover" $ showExps tt [x] ++ [showExp' tt (ESymbol Accent "\8594")]
     EOver _ x y      -> unode "mover" $ showExps tt [x] ++ [showExp' tt y]
     EUnderover _ x y z -> unode "munderover" $
                            showExps tt [x] ++ [showExp' tt y, showExp' tt z]
     EPhantom x       -> unode "mphantom" $ showExps tt [x]
     EBoxed x         -> withAttribute "notation" "box" .
                         unode "menclose" $ showExp tt x
     ECancel ForwardSlash x -> withAttribute "notation" "updiagonalstrike" .
                               unode "menclose" $ showExp tt x
     ECancel BackSlash x    -> withAttribute "notation" "downdiagonalstrike" .
                               unode "menclose" $ showExp tt x
     ECancel XSlash x       -> withAttribute "notation" "updiagonalstrike downdiagonalstrike" .
                               unode "menclose" $ showExp tt x
     ESqrt x          -> unode "msqrt" $ showExp tt x
     ERoot i x        -> unode "mroot" [showExp tt x, showExp tt i]
     EScaled s x      -> makeScaled s $ showExp tt x
     EArray as ls     -> makeArray tt as ls
     EText a s        -> case (tt, a) of
                           (Just ty, TextNormal) -> makeText ty s
                           _ -> makeText a s
     EStyled a es     -> showExp (Just a) (EGrouped 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 s = unode s . T.unpack
  