1{-# LANGUAGE ViewPatterns #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-
4Copyright (C) 2014 Matthew Pickering <matthewtpickering@gmail.com>
5
6This program is free software; you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
8the Free Software Foundation; either version 2 of the License, or
9(at your option) any later version.
10
11This program is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14GNU General Public License for more details.
15
16You should have received a copy of the GNU General Public License
17along with this program; if not, write to the Free Software
18Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
19-}
20{- |
21
22Parses MathML in conformance with the MathML3 specification.
23
24Unimplemented features:
25
26  - mpadded
27  - malignmark
28  - maligngroup
29  - Elementary Math
30
31To Improve:
32
33  - Handling of menclose
34  - Handling of mstyle
35-}
36
37module Text.TeXMath.Readers.MathML (readMathML) where
38
39import Text.XML.Light hiding (onlyText)
40import Text.TeXMath.Types
41import Text.TeXMath.Readers.MathML.MMLDict (getMathMLOperator)
42import Text.TeXMath.Readers.MathML.EntityMap (getUnicode)
43import Text.TeXMath.Shared (getTextType, readLength, getOperator, fixTree,
44                            getSpaceWidth, isEmpty, empty)
45import Text.TeXMath.Unicode.ToTeX (getSymbolType)
46import Text.TeXMath.Unicode.ToUnicode (fromUnicode)
47import Text.TeXMath.Compat (throwError, Except, runExcept, MonadError)
48import Control.Applicative ((<$>), (<|>), (<*>))
49import Control.Arrow ((&&&))
50import Data.Char (toLower)
51import Data.Maybe (fromMaybe, listToMaybe, isJust)
52import Data.Monoid (mconcat, First(..), getFirst)
53import Data.Semigroup ((<>))
54import Data.List (transpose)
55import qualified Data.Text as T
56import Control.Monad (filterM, guard)
57import Control.Monad.Reader (ReaderT, runReaderT, asks, local)
58import Data.Either (rights)
59
60-- | Parse a MathML expression to a list of 'Exp'.
61readMathML :: T.Text -> Either T.Text [Exp]
62readMathML inp = map fixTree <$>
63  (runExcept (flip runReaderT defaultState (i >>= parseMathML)))
64  where
65    i = maybeToEither "Invalid XML" (parseXMLDoc inp)
66
67data MMLState = MMLState { attrs :: [Attr]
68                         , position :: Maybe FormType
69                         , inAccent :: Bool
70                         , curStyle :: TextType }
71
72type MML = ReaderT MMLState (Except T.Text)
73
74data SupOrSub = Sub | Sup deriving (Show, Eq)
75
76data IR a = Stretchy TeXSymbolType (T.Text -> Exp) T.Text
77          | Trailing (Exp -> Exp -> Exp) Exp
78          | E a
79
80instance Show a => Show (IR a) where
81  show (Stretchy t _ s) = "Stretchy " ++ show t ++ " " ++ show s
82  show (Trailing _ s) = "Trailing " ++ show s
83  show (E s) = "E " ++ show s
84
85parseMathML :: Element -> MML [Exp]
86parseMathML e@(name -> "math") = do
87  e' <- row e
88  return $
89    case e' of
90      EGrouped es -> es
91      _ -> [e']
92parseMathML _ = throwError "Root must be math element"
93
94expr :: Element -> MML [IR Exp]
95expr e = local (addAttrs (elAttribs e)) (expr' e)
96
97expr' :: Element -> MML [IR Exp]
98expr' e =
99  case name e of
100    "mi" -> mkE <$> ident e
101    "mn" -> mkE <$> number e
102    "mo" -> (:[]) <$> op e
103    "mtext" -> mkE <$> text e
104    "ms" -> mkE <$> literal e
105    "mspace" -> mkE <$> space e
106    "mrow" -> mkE <$> row e
107    "mstyle" -> mkE <$> style e
108    "mfrac" -> mkE <$> frac e
109    "msqrt" -> mkE <$> msqrt e
110    "mroot" -> mkE <$> kroot e
111    "merror" -> return (mkE empty)
112    "mpadded" -> mkE <$> row e
113    "mphantom" -> mkE <$> phantom e
114    "mfenced" -> mkE <$> fenced e
115    "menclose" -> mkE <$> enclosed e
116    "msub" ->  sub e
117    "msup" ->  sup e
118    "msubsup" -> mkE <$> subsup e
119    "munder" -> mkE <$> under e
120    "mover" -> mkE <$> over e
121    "munderover" -> mkE <$> underover e
122    "mtable" -> mkE <$> table e
123    "maction" -> mkE <$> action e
124    "semantics" -> mkE <$> semantics e
125    "maligngroup" -> return $ mkE empty
126    "malignmark" -> return $ mkE empty
127    "mmultiscripts" -> mkE <$> multiscripts e
128    _ -> throwError $ "Unexpected element " <> err e
129  where
130    mkE :: Exp -> [IR Exp]
131    mkE = (:[]) . E
132
133
134-- Tokens
135
136ident :: Element -> MML Exp
137ident e =  do
138  s <- getString e
139  let base = case getOperator (EMathOperator s) of
140                   Just _   -> EMathOperator s
141                   Nothing  -> EIdentifier s
142  mbVariant <- findAttrQ "mathvariant" e
143  curstyle <- asks curStyle
144  case mbVariant of
145       Nothing  -> return base
146       Just v
147         | curstyle == getTextType v -> return base
148         | otherwise  -> return $ EStyled (getTextType v) [base]
149
150number :: Element -> MML Exp
151number e = ENumber <$> getString e
152
153op :: Element -> MML (IR Exp)
154op e = do
155  mInferredPosition <- (<|>) <$> (getFormType <$> findAttrQ "form" e)
156                            <*> asks position
157  inferredPosition <- case mInferredPosition of
158    Just inferredPosition -> pure inferredPosition
159    Nothing               -> throwError "Did not find an inferred position"
160  opString <- getString e
161  let dummy = Operator opString "" inferredPosition 0 0 0 []
162  let opLookup = getMathMLOperator opString inferredPosition
163  let opDict = fromMaybe dummy opLookup
164  props <- filterM (checkAttr (properties opDict))
165            ["fence", "accent", "stretchy"]
166  let objectPosition = getPosition $ form opDict
167  inScript <- asks inAccent
168  let ts =  [("accent", ESymbol Accent), ("fence", ESymbol objectPosition)]
169  let fallback = case T.unpack opString of
170                   [t] -> ESymbol (getSymbolType t)
171                   _   -> if isJust opLookup
172                          then ESymbol Ord
173                          else EMathOperator
174  let constructor =
175        fromMaybe fallback
176          (getFirst . mconcat $ map (First . flip lookup ts) props)
177  if ("stretchy" `elem` props) && not inScript
178    then return $ Stretchy objectPosition constructor opString
179    else do
180      return $ (E . constructor) opString
181  where
182    checkAttr ps v = maybe (v `elem` ps) (=="true") <$> findAttrQ (T.unpack v) e
183
184text :: Element -> MML Exp
185text e = do
186  textStyle <- maybe TextNormal getTextType
187                <$> (findAttrQ "mathvariant" e)
188  s <- getString e
189  -- mathml seems to use mtext for spacing often; we get
190  -- more idiomatic math if we replace these with ESpace:
191  return $ case (textStyle, T.unpack s) of
192       (TextNormal, [c]) ->
193         case getSpaceWidth c of
194              Just w  -> ESpace w
195              Nothing -> EText textStyle s
196       _ -> EText textStyle s
197
198literal :: Element -> MML Exp
199literal e = do
200  lquote <- fromMaybe "\x201C" <$> findAttrQ "lquote" e
201  rquote <- fromMaybe "\x201D" <$> findAttrQ "rquote" e
202  textStyle <- maybe TextNormal getTextType
203                <$> (findAttrQ "mathvariant" e)
204  s <- getString e
205  return $ EText textStyle $ lquote <> s <> rquote
206
207space :: Element -> MML Exp
208space e = do
209  width <- fromMaybe "0.0em" <$> (findAttrQ "width" e)
210  return $ ESpace (widthToNum width)
211
212-- Layout
213
214style :: Element -> MML Exp
215style e = do
216  tt <- maybe TextNormal getTextType <$> findAttrQ "mathvariant" e
217  curstyle <- asks curStyle
218  -- We do not want to propagate the mathvariant else
219  -- we end up with nested EStyled applying the same
220  -- style
221  result <- local (filterMathVariant . enterStyled tt) (row e)
222  return $ if curstyle == tt
223              then result
224              else EStyled tt [result]
225
226row :: Element -> MML Exp
227row e = mkExp <$> group e
228
229-- 1. matchNesting strips all additional IR
230-- 2. toEDelim
231-- 3. toExp makes sure that no additional nesting happens
232mkExp :: [IR Exp] -> Exp
233mkExp = toExp . toEDelim . matchNesting
234
235toExp :: [InEDelimited] -> Exp
236toExp [] = empty
237toExp xs =
238  if any isStretchy xs
239    then case xs of
240              [x] -> either (ESymbol Ord) id x
241              _ -> EDelimited "" "" xs
242    else
243      case xs of
244        [Right x] -> x
245        _ -> EGrouped (rights xs)
246
247
248toEDelim :: [IR InEDelimited] -> [InEDelimited]
249toEDelim [] = []
250toEDelim [Stretchy _ con s] = [Right $ con s]
251toEDelim (xs) = map removeIR xs
252
253-- Strips internal representation from processed list
254removeIR :: IR a -> a
255removeIR (E e) = e
256removeIR _ = error "removeIR, should only be ever called on processed lists"
257
258-- Convers stretch to InEDelimited element
259removeStretch :: [IR Exp] -> [IR InEDelimited]
260removeStretch [Stretchy _ constructor s] = [E $ Right (constructor s)]
261removeStretch xs = map f xs
262  where
263    f (Stretchy _ _ s) = E $ Left s
264    f (E e) = E $ Right e
265    f (Trailing a b) = Trailing a b
266
267isStretchy :: InEDelimited -> Bool
268isStretchy (Left _) = True
269isStretchy (Right _) = False
270
271-- If at the end of a delimiter we need to apply the script to the whole
272-- expression. We only insert Trailing when reordering Stretchy
273trailingSup :: Maybe (T.Text, T.Text -> Exp)  -> Maybe (T.Text, T.Text -> Exp)  -> [IR InEDelimited] -> Exp
274trailingSup open close es = go es
275  where
276    go [] = case (open, close) of
277              (Nothing, Nothing) -> empty
278              (Just (openFence, conOpen), Nothing) -> conOpen openFence
279              (Nothing, Just (closeFence, conClose)) -> conClose closeFence
280              (Just (openFence, conOpen), Just (closeFence, conClose))  ->
281                EGrouped [conOpen openFence, conClose closeFence]
282    go es'@(last -> Trailing constructor e) = (constructor (go (init es')) e)
283    go es' = EDelimited (getFence open) (getFence close) (toEDelim es')
284    getFence = fromMaybe "" . fmap fst
285
286-- TODO: Break this into two functions
287-- Matches open and closing brackets
288-- The result of this function is a list with only E elements.
289matchNesting :: [IR Exp] -> [IR InEDelimited]
290matchNesting ((break isFence) -> (inis, rest)) =
291  let inis' = removeStretch inis in
292  case rest of
293    [] -> inis'
294    ((Stretchy Open conOpen opens): rs) ->
295      let jOpen = Just (opens, conOpen)
296          (body, rems) = go rs 0 []
297          body' = matchNesting body in
298        case rems of
299          [] -> inis' ++ [E $ Right $ trailingSup jOpen Nothing body']
300          (Stretchy Close conClose closes : rs') ->
301            let jClose = Just (closes, conClose) in
302            inis' ++ (E $ Right $ trailingSup jOpen jClose body') : matchNesting rs'
303          _ -> (error "matchNesting: Logical error 1")
304    ((Stretchy Close conClose closes): rs) ->
305      let jClose = Just (closes, conClose) in
306      (E $ Right $ trailingSup Nothing jClose (matchNesting inis)) : matchNesting rs
307    _ -> error "matchNesting: Logical error 2"
308  where
309    isOpen (Stretchy Open _ _) = True
310    isOpen _ = False
311    isClose (Stretchy Close _ _) = True
312    isClose _ = False
313    go :: [IR a] -> Int -> [IR a] -> ([IR a], [IR a])
314    go (x:xs) 0 a | isClose x = (reverse a, x:xs)
315    go (x:xs) n a | isOpen x  = go xs (n + 1) (x:a)
316    go (x:xs) n a | isClose x = go xs (n - 1) (x:a)
317    go (x:xs) n a = go xs n (x:a)
318    go [] _ a = (reverse a, [])
319
320isFence :: IR a -> Bool
321isFence (Stretchy Open _ _) = True
322isFence (Stretchy Close _ _) = True
323isFence _ = False
324
325group :: Element -> MML [IR Exp]
326group e = do
327  front <- concat <$> mapM expr frontSpaces
328  middle <- local resetPosition (row' body)
329  end <- concat <$> local resetPosition (mapM expr endSpaces)
330  return $ (front ++ middle ++ end)
331  where
332    cs = elChildren e
333    (frontSpaces, noFront)  = span spacelike cs
334    (endSpaces, body) = let (as, bs) = span spacelike (reverse noFront) in
335                          (reverse as, reverse bs)
336
337row' :: [Element] -> MML [IR Exp]
338row' [] = return []
339row' [x] = do
340              pos <- maybe FInfix (const FPostfix) <$> asks position
341              local (setPosition pos) (expr x)
342row' (x:xs) =
343  do
344    pos <- maybe FPrefix (const FInfix) <$> asks position
345    e  <- local (setPosition pos) (expr x)
346    es <- local (setPosition pos) (row' xs)
347    return (e ++ es)
348
349-- Indicates the closure of scope
350safeExpr :: Element -> MML Exp
351safeExpr e = mkExp <$> expr e
352
353frac :: Element -> MML Exp
354frac e = do
355  (num, denom) <- mapPairM safeExpr =<< (checkArgs2 e)
356  rawThick <- findAttrQ "linethickness" e
357  return $
358    if thicknessZero rawThick
359       then EFraction NoLineFrac num denom
360       else EFraction NormalFrac num denom
361
362msqrt :: Element -> MML Exp
363msqrt e = ESqrt <$> (row e)
364
365kroot :: Element -> MML Exp
366kroot e = do
367  (base, index) <- mapPairM safeExpr =<< (checkArgs2 e)
368  return $ ERoot index base
369
370phantom :: Element -> MML Exp
371phantom e = EPhantom <$> row e
372
373fenced :: Element -> MML Exp
374fenced e = do
375  open  <- fromMaybe "(" <$> (findAttrQ "open" e)
376  close <- fromMaybe ")" <$> (findAttrQ "close" e)
377  sep  <- fromMaybe "," <$> (findAttrQ "separators" e)
378  let expanded =
379        case sep of
380          "" -> elChildren e
381          _  ->
382            let seps = map (\x -> unode "mo" [x]) $ T.unpack sep
383                sepsList = seps ++ repeat (last seps) in
384                fInterleave (elChildren e) (sepsList)
385  safeExpr $ unode "mrow"
386              ([tunode "mo" open | not $ T.null open] ++
387               [unode "mrow" expanded] ++
388               [tunode "mo" close | not $ T.null close])
389
390-- This could approximate the variants
391enclosed :: Element -> MML Exp
392enclosed e = do
393  mbNotation <- findAttrQ "notation" e
394  case mbNotation of
395       Just "box" -> EBoxed <$> row e
396       _ -> row e
397
398action :: Element -> MML Exp
399action e = do
400  selection <-  maybe 1 (read . T.unpack) <$> (findAttrQ "selection" e)  -- 1-indexing
401  safeExpr =<< maybeToEither ("Selection out of range")
402            (listToMaybe $ drop (selection - 1) (elChildren e))
403
404-- Scripts and Limits
405
406sub :: Element -> MML [IR Exp]
407sub e =  do
408  (base, subs) <- checkArgs2 e
409  reorderScripts base subs ESub
410
411-- Handles case with strethy elements in the base of sub/sup
412reorderScripts :: Element -> Element -> (Exp -> Exp -> Exp) -> MML [IR Exp]
413reorderScripts e subs c = do
414  baseExpr <- expr e
415  subExpr <- postfixExpr subs
416  return $
417    case baseExpr of
418      [s@(Stretchy Open _ _)] -> [s, E $ c empty subExpr]  -- Open
419      [s@(Stretchy Close _ _)] -> [Trailing c subExpr, s] -- Close
420      [s@(Stretchy _ _ _)] -> [s, E $ ESub empty subExpr] -- Middle
421      _ -> [E $ c (mkExp baseExpr) subExpr] -- No stretch
422
423sup :: Element -> MML [IR Exp]
424sup e = do
425  (base, sups) <- checkArgs2 e
426  reorderScripts base sups ESuper
427
428subsup :: Element -> MML Exp
429subsup e = do
430  (base, subs, sups) <- checkArgs3 e
431  ESubsup <$> safeExpr base <*> (postfixExpr subs)
432                         <*> (postfixExpr sups)
433
434under :: Element -> MML Exp
435under e = do
436  (base, below) <- checkArgs2 e
437  EUnder False <$> safeExpr base <*> postfixExpr below
438
439over :: Element -> MML Exp
440over e = do
441  (base, above) <- checkArgs2 e
442  EOver False <$> safeExpr base <*> postfixExpr above
443
444underover :: Element -> MML Exp
445underover e = do
446  (base, below, above) <- checkArgs3 e
447  EUnderover False <$> safeExpr base  <*> (postfixExpr below)
448                                      <*> (postfixExpr above)
449
450-- Other
451
452semantics :: Element -> MML Exp
453semantics e = do
454  guard (not $ null cs)
455  first <- safeExpr (head cs)
456  if isEmpty first
457    then fromMaybe empty . getFirst . mconcat <$> mapM annotation (tail cs)
458    else return first
459  where
460    cs = elChildren e
461
462annotation :: Element -> MML (First Exp)
463annotation e = do
464  encoding <- findAttrQ "encoding" e
465  case encoding of
466    Just "application/mathml-presentation+xml" ->
467      First . Just <$> row e
468    Just "MathML-Presentation" ->
469      First . Just <$> row e
470    _ -> return (First Nothing)
471
472multiscripts :: Element -> MML Exp
473multiscripts e = do
474  let (xs, pres) = break ((== "mprescripts") . name) (elChildren e)
475  let row'' e' = if name e' == "none"
476                    then return $ EGrouped []
477                    else row e'
478  xs' <- mapM row'' xs
479  let base =
480        case xs' of
481          [x]       -> x
482          [x,y]     -> ESub x y
483          (x:y:z:_) -> ESubsup x y z
484          []        -> EGrouped []
485  pres' <- mapM row'' $ drop 1 pres
486  return $
487    case pres' of
488        (x:y:_) -> EGrouped [ESubsup (EGrouped []) x y, base]
489        [x]     -> EGrouped [ESub x (EGrouped []), base]
490        []      -> base
491
492
493-- Table
494
495table :: Element -> MML Exp
496table e = do
497  defAlign <- maybe AlignCenter toAlignment <$> (findAttrQ "columnalign" e)
498  rs <- mapM (tableRow defAlign) (elChildren e)
499  let (onlyAligns, exprs) = (map .map) fst &&& (map . map) snd $ rs
500  let rs' = map (pad (maximum (map length rs))) exprs
501  let aligns = map findAlign (transpose onlyAligns)
502  return $ EArray aligns rs'
503  where
504    findAlign xs = if null xs then AlignCenter
505                    else foldl1 combine xs
506    combine x y = if x == y then x else AlignCenter
507
508tableRow :: Alignment -> Element -> MML [(Alignment, [Exp])]
509tableRow a e = do
510  align <- maybe a toAlignment <$> (findAttrQ "columnalign" e)
511  case name e of
512    "mtr" -> mapM (tableCell align) (elChildren e)
513    "mlabeledtr" -> mapM (tableCell align) (tail $ elChildren e)
514    _ -> throwError $ "Invalid Element: Only expecting mtr elements " <> err e
515
516tableCell :: Alignment -> Element -> MML (Alignment, [Exp])
517tableCell a e = do
518  align <- maybe a toAlignment <$> (findAttrQ "columnalign" e)
519  case name e of
520    "mtd" -> (,) align . (:[]) <$> row e
521    _ -> throwError $ "Invalid Element: Only expecting mtd elements " <> err e
522
523-- Fixup
524
525-- Library Functions
526
527maybeToEither :: (MonadError e m) => e -> Maybe a -> m a
528maybeToEither = flip maybe return . throwError
529
530--interleave up to end of shorter list
531fInterleave :: [a] -> [a] -> [a]
532fInterleave [] _ = []
533fInterleave _ [] = []
534fInterleave (x:xs) ys = x : fInterleave ys xs
535
536-- MMLState helper functions
537
538defaultState :: MMLState
539defaultState = MMLState [] Nothing False TextNormal
540
541addAttrs :: [Attr] -> MMLState -> MMLState
542addAttrs as s = s {attrs = (map renameAttr as) ++ attrs s }
543
544renameAttr :: Attr -> Attr
545renameAttr v@(qName . attrKey -> "accentunder") =
546  Attr (unqual "accent") (attrVal v)
547renameAttr a = a
548
549filterMathVariant :: MMLState -> MMLState
550filterMathVariant s@(attrs -> as) =
551  s{attrs = filter ((/= unqual "mathvariant") . attrKey) as}
552
553setPosition :: FormType -> MMLState -> MMLState
554setPosition p s = s {position = Just p}
555
556resetPosition :: MMLState -> MMLState
557resetPosition s = s {position = Nothing}
558
559enterAccent :: MMLState -> MMLState
560enterAccent s = s{ inAccent = True }
561
562enterStyled :: TextType -> MMLState -> MMLState
563enterStyled tt s = s{ curStyle = tt }
564
565-- Utility
566
567getString :: Element -> MML T.Text
568getString e = do
569  tt <- asks curStyle
570  return $ fromUnicode tt $ stripSpaces $ T.pack $ concatMap cdData
571         $ onlyText $ elContent $ e
572
573-- Finds only text data and replaces entity references with corresponding
574-- characters
575onlyText :: [Content] -> [CData]
576onlyText [] = []
577onlyText ((Text c):xs) = c : onlyText xs
578onlyText (CRef s : xs)  = (CData CDataText (fromMaybe s $ getUnicode' s) Nothing) : onlyText xs
579  where getUnicode' = fmap T.unpack . getUnicode . T.pack
580onlyText (_:xs) = onlyText xs
581
582checkArgs2 :: Element -> MML (Element, Element)
583checkArgs2 e = case elChildren e of
584  [a, b] -> return (a, b)
585  _      -> throwError ("Incorrect number of arguments for " <> err e)
586
587checkArgs3 :: Element -> MML (Element, Element, Element)
588checkArgs3 e = case elChildren e of
589  [a, b, c] -> return (a, b, c)
590  _         -> throwError ("Incorrect number of arguments for " <> err e)
591
592mapPairM :: Monad m => (a -> m b) -> (a, a) -> m (b, b)
593mapPairM f (a, b) = (,) <$> (f a) <*> (f b)
594
595err :: Element -> T.Text
596err e = name e <> maybe "" (\x -> " line " <> T.pack (show x)) (elLine e)
597
598-- Kept as String for Text.XML.Light
599findAttrQ :: String -> Element -> MML (Maybe T.Text)
600findAttrQ s e = do
601  inherit <- case (name e, s) of
602            ("mfenced", "open") -> return Nothing
603            ("mfenced", "close") -> return Nothing
604            ("mfenced", "separators") -> return Nothing
605            _ -> asks (lookupAttrQ s . attrs)
606  return $ fmap T.pack $
607    findAttr (QName s Nothing Nothing) e
608      <|> inherit
609
610-- Kept as String for Text.XML.Light
611lookupAttrQ :: String -> [Attr] -> Maybe String
612lookupAttrQ s = lookupAttr (QName (map toLower s) Nothing Nothing)
613
614name :: Element -> T.Text
615name (elName -> (QName n _ _)) = T.toLower $ T.pack n
616
617-- Kept as String for Text.XML.Light
618tunode :: String -> T.Text -> Element
619tunode s = unode s . T.unpack
620
621stripSpaces :: T.Text -> T.Text
622stripSpaces = T.dropAround isSpace
623
624toAlignment :: T.Text -> Alignment
625toAlignment "left" = AlignLeft
626toAlignment "center" = AlignCenter
627toAlignment "right" = AlignRight
628toAlignment _ = AlignCenter
629
630getPosition :: FormType -> TeXSymbolType
631getPosition (FPrefix) = Open
632getPosition (FPostfix) = Close
633getPosition (FInfix) = Op
634
635getFormType :: Maybe T.Text -> Maybe FormType
636getFormType (Just "infix") = (Just FInfix)
637getFormType (Just "prefix") = (Just FPrefix)
638getFormType (Just "postfix") = (Just FPostfix)
639getFormType _ = Nothing
640
641pad :: Int -> [[a]] -> [[a]]
642pad n xs = xs ++ (replicate (n - len) [])
643  where
644    len = length xs
645
646isSpace :: Char -> Bool
647isSpace ' '  = True
648isSpace '\t' = True
649isSpace '\n' = True
650isSpace _    = False
651
652spacelikeElems, cSpacelikeElems :: [T.Text]
653spacelikeElems = ["mtext", "mspace", "maligngroup", "malignmark"]
654cSpacelikeElems = ["mrow", "mstyle", "mphantom", "mpadded"]
655
656spacelike :: Element -> Bool
657spacelike e@(name -> uid) =
658  uid `elem` spacelikeElems || uid `elem` cSpacelikeElems &&
659    and (map spacelike (elChildren e))
660
661thicknessZero :: Maybe T.Text -> Bool
662thicknessZero (Just s) = thicknessToNum s == 0.0
663thicknessZero Nothing  = False
664
665widthToNum :: T.Text -> Rational
666widthToNum s =
667  case s of
668       "veryverythinmathspace"  -> 1/18
669       "verythinmathspace"      -> 2/18
670       "thinmathspace"          -> 3/18
671       "mediummathspace"        -> 4/18
672       "thickmathspace"         -> 5/18
673       "verythickmathspace"     -> 6/18
674       "veryverythickmathspace" -> 7/18
675       "negativeveryverythinmathspace"  -> -1/18
676       "negativeverythinmathspace"      -> -2/18
677       "negativethinmathspace"          -> -3/18
678       "negativemediummathspace"        -> -4/18
679       "negativethickmathspace"         -> -5/18
680       "negativeverythickmathspace"     -> -6/18
681       "negativeveryverythickmathspace" -> -7/18
682       _ -> fromMaybe 0 (readLength s)
683
684thicknessToNum :: T.Text -> Rational
685thicknessToNum s =
686  case s of
687       "thin" -> (3/18)
688       "medium" -> (1/2)
689       "thick" -> 1
690       v -> fromMaybe 0.5 (readLength v)
691
692postfixExpr :: Element -> MML Exp
693postfixExpr e = local (setPosition FPostfix . enterAccent) (safeExpr e)
694