{-
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.MathML (toMathML, DisplayType(..), showExp)
where

import qualified Data.Map as M
import Text.XML.Light
import Text.TeXMath.Types
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"

{- Firefox seems to set spacing based on its own dictionary,
-  so I believe this is unnecessary.
 
setSpacing :: String -> String -> Bool -> Element -> Element
setSpacing left right stretchy elt =
  add_attr (Attr (unqual "lspace") left) $
  add_attr (Attr (unqual "rspace") right) $
  if stretchy
     then add_attr (Attr (unqual "stretchy") "true") elt
     else elt

showSymbol (ESymbol s x) =
  case s of
    Ord   x  -> unode "mo" x
    Op    x  -> setSpacing "0" "0.167em" True $ unode "mo" x
    Bin   x  -> setSpacing "0.222em" "0.222em" False $ unode "mo" x
    Rel   x  -> setSpacing "0.278em" "0.278em" False $ unode "mo" x
    Open  x  -> setSpacing "0" "0" True $ unode "mo" x
    Close x  -> setSpacing "0" "0" True $ unode "mo" x
    Pun   x  -> setSpacing "0" "0.167em" False $ unode "mo" x
-}

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
                       -- note: EUp, EDown, EDownup should be removed by handleDownup