content: {-# LANGUAGE PatternGuards #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE LambdaCase #-}
  
  {-
  Copyright (C) 2014 Jesse Rosenthal <jrosenthal@jhu.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
  -}
  
  {- |
   Module : Text.TeXMath.Readers.OMML
   Copyright : Copyright (C) 2014 Jesse Rosenthal
   License : GNU GPL, version 2 or above
  
   Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
   Stability : alpha
   Portability : portable
  
  Types and functions for conversion of OMML into TeXMath 'Exp's.
  -}
  
  module Text.TeXMath.Readers.OMML (readOMML) where
  
  import Text.XML.Light
  import Data.Maybe (isJust, mapMaybe, fromMaybe, maybeToList)
  import Data.List (intercalate)
  import Data.Char (isDigit, readLitChar)
  import qualified Data.Text as T
  import Text.TeXMath.Types
  import Text.TeXMath.Shared (fixTree, getSpaceWidth, getOperator)
  import Text.TeXMath.Unicode.ToTeX (getSymbolType)
  import Text.TeXMath.Unicode.Fonts (getUnicode, textToFont)
  import Data.List.Split (splitWhen)
  
  readOMML :: T.Text -> Either T.Text [Exp]
  readOMML s | Just e <- parseXMLDoc s =
    case elemToOMML e of
      Just exs -> Right $ map fixTree $ unGroup exs
      Nothing   -> Left "xml file was not an <m:oMathPara> or <m:oMath> element."
  readOMML _ = Left "Couldn't parse OMML file"
  
  unGroup :: [Exp] -> [Exp]
  unGroup [EGrouped exps] = exps
  unGroup exps = exps
  
  elemToOMML :: Element -> Maybe [Exp]
  elemToOMML element  | isElem "m" "oMathPara" element = do
    let expList = mapMaybe elemToOMML (elChildren element)
    return $ map (\case
                     [x] -> x
                     xs -> EGrouped xs) expList
  elemToOMML element  | isElem "m" "oMath" element =
    Just $ elemsToExps $ unwrapWTags $ elChildren element
  elemToOMML _ = Nothing
  
  -- oMath can contain w:hyperlink, w:sdt, etc. I can't find a complete
  -- documentation of this, so we just unwrap any w:tag immediately
  -- beneath oMath. Note that this shouldn't affect the "w" tags in
  -- elemToOMathRunElem(s) because, those are underneath an "m:r" tag.
  unwrapWTags :: [Element] -> [Element]
  unwrapWTags elements = concatMap unwrapChild elements
    where unwrapChild element = case qPrefix $ elName element of
                                  Just "w" -> elChildren element
                                  _        -> [element]
  
  -- Kept as String because of Text.XML.Light
  isElem :: String -> String -> Element -> Bool
  isElem prefix name element =
    let qp = fromMaybe "" (qPrefix (elName element))
    in
     qName (elName element) == name &&
     qp == prefix
  
  -- Kept as String because of Text.XML.Light
  hasElemName :: String -> String -> QName -> Bool
  hasElemName prefix name qn =
    let qp = fromMaybe "" (qPrefix qn)
    in
     qName qn == name &&
     qp       == prefix
  
  data OMathRunElem = TextRun T.Text
                    | LnBrk
                    | Tab
                      deriving Show
  
  data OMathRunTextStyle = NoStyle
                         | Normal
                         | Styled { oMathScript :: Maybe OMathTextScript
                                  , oMathStyle  :: Maybe OMathTextStyle }
                         deriving Show
  
  data OMathTextScript = ORoman
                       | OScript
                       | OFraktur
                       | ODoubleStruck
                       | OSansSerif
                       | OMonospace
                       deriving (Show, Eq)
  
  data OMathTextStyle = OPlain
                      | OBold
                      | OItalic
                      | OBoldItalic
                      deriving (Show, Eq)
  
  
  breakOnAmpersand :: [Exp] -> [[Exp]]
  breakOnAmpersand = splitWhen isAmpersand
   where
    isAmpersand (ESymbol _ "&") = True
    isAmpersand _ = False
  
  elemToOMathRunTextStyle :: Element -> OMathRunTextStyle
  elemToOMathRunTextStyle element
    | Just mrPr <- filterChildName (hasElemName"m" "rPr") element
    , Just _    <- filterChildName (hasElemName"m" "nor") mrPr =
      Normal
    | Just mrPr <- filterChildName (hasElemName"m" "rPr") element =
      let scr =
            case
              filterChildName (hasElemName"m" "scr") mrPr >>=
              findAttrBy (hasElemName"m" "val")
            of
              Just "roman"         -> Just ORoman
              Just "script"        -> Just OScript
              Just "fraktur"       -> Just OFraktur
              Just "double-struck" -> Just ODoubleStruck
              Just "sans-serif"    -> Just OSansSerif
              Just "monospace"     -> Just OMonospace
              _                    -> Nothing
  
          sty =
            case
              filterChildName (hasElemName"m" "sty") mrPr >>=
              findAttrBy (hasElemName"m" "val")
            of
              Just "p"             -> Just OPlain
              Just "b"             -> Just OBold
              Just "i"             -> Just OItalic
              Just "bi"            -> Just OBoldItalic
              _                    -> Nothing
      in
       Styled { oMathScript = scr, oMathStyle = sty }
    | otherwise = NoStyle
  
  elemToOMathRunElem :: Element -> Maybe OMathRunElem
  elemToOMathRunElem element
    | isElem "w" "t" element
      || isElem "m" "t" element
      || isElem "w" "delText" element = Just $ TextRun $ T.pack $ strContent element
    | isElem "w" "br" element = Just LnBrk
    | isElem "w" "tab" element = Just Tab
    | isElem "w" "sym" element = Just $ TextRun $ getSymChar element
    | otherwise = Nothing
  
  elemToOMathRunElems :: Element -> Maybe [OMathRunElem]
  elemToOMathRunElems element
    | isElem "w" "r" element
      || isElem "m" "r" element =
        Just $ mapMaybe (elemToOMathRunElem) (elChildren element)
  elemToOMathRunElems _ = Nothing
  
  ----- And now the TeXMath Creation
  
  oMathRunElemToText :: OMathRunElem -> T.Text
  oMathRunElemToText (TextRun s) = s
  oMathRunElemToText (LnBrk) = "\n"
  oMathRunElemToText (Tab) = "\t"
  
  oMathRunElemsToText :: [OMathRunElem] -> T.Text
  oMathRunElemsToText = T.concat . map oMathRunElemToText
  
  oMathRunTextStyleToTextType :: OMathRunTextStyle -> Maybe TextType
  oMathRunTextStyleToTextType (Normal) = Just $ TextNormal
  oMathRunTextStyleToTextType (NoStyle) = Nothing
  oMathRunTextStyleToTextType (Styled scr sty)
    | Just OBold <- sty
    , Just OSansSerif <- scr =
      Just $ TextSansSerifBold
    | Just OBoldItalic <- sty
    , Just OSansSerif <- scr =
      Just $ TextSansSerifBoldItalic
    | Just OBold <- sty
    , Just OScript <- scr =
      Just $ TextBoldScript
    | Just OBold <- sty
    , Just OFraktur <- scr =
      Just $ TextBoldFraktur
    | Just OItalic <- sty
    , Just OSansSerif <- scr =
      Just $ TextSansSerifItalic
    | Just OBold <- sty =
      Just $ TextBold
    | Just OItalic <- sty =
      Just $ TextItalic
    | Just OMonospace <- scr =
      Just $ TextMonospace
    | Just OSansSerif <- scr =
      Just $ TextSansSerif
    | Just ODoubleStruck <- scr =
      Just $ TextDoubleStruck
    | Just OScript <- scr =
      Just $ TextScript
    | Just OFraktur <- scr =
      Just $ TextFraktur
    | Just OBoldItalic <- sty =
      Just $ TextBoldItalic
    | otherwise = Nothing
  
  -- merge adjacent Exps with same style; see jgm/pandoc#10560:
  mergeExps :: [Exp] -> [Exp]
  mergeExps [] = []
  mergeExps (EStyled tt xs : EStyled tt' xs' : rest)
    | tt == tt' = mergeExps (EStyled tt (xs <> xs') : rest)
  mergeExps (EText tt x : EText tt' x' : rest)
    | tt == tt' = mergeExps (EText tt (x <> x') : rest)
  mergeExps (x:xs) = x : mergeExps xs
  
  elemsToExps :: [Element] -> [Exp]
  elemsToExps = mergeExps . concat . mapMaybe elemToExps
  
  elemToExps :: Element -> Maybe [Exp]
  elemToExps element = unGroup <$> elemToExps' element
  
  elemToBase :: Element -> Maybe Exp
  elemToBase element | isElem "m" "e" element = do
    bs <- elemToBases element
    return $ case bs of
      (e : []) -> e
      exps     -> EGrouped exps
  elemToBase _ = Nothing
  
  elemToBases :: Element -> Maybe [Exp]
  elemToBases element | isElem "m" "e" element =
    return $ concat $ mapMaybe elemToExps' (elChildren element)
  elemToBases _ = Nothing
  
  
  
  elemToExps' :: Element -> Maybe [Exp]
  elemToExps' element | isElem "m" "acc" element = do
    let chr = filterChildName (hasElemName "m" "accPr") element >>=
              filterChildName (hasElemName "m" "chr") >>=
              findAttrBy (hasElemName "m" "val")
        chr' = maybe "\x302" T.pack chr  -- default to wide hat
    baseExp <- filterChildName (hasElemName "m" "e") element >>=
               elemToBase
    return $ [EOver False baseExp (ESymbol Accent chr')]
  elemToExps' element | isElem "m" "bar" element = do
    let pos = filterChildName (hasElemName "m" "barPr") element >>=
              filterChildName (hasElemName "m" "pos") >>=
              findAttrBy (hasElemName "m" "val")
    baseExp <- filterChildName (hasElemName "m" "e") element >>=
               elemToBase
    -- According to OMML Specification, the default value of pos (whether it exists or not) is "bot"
    -- see https://github.com/jgm/texmath/issues/187
    case pos of
      Just "top" -> Just [EOver False baseExp (ESymbol TOver "\773")]
      _          -> Just [EUnder False baseExp (ESymbol TUnder "\818")]
  elemToExps' element | isElem "m" "box" element = do
    baseExp <- filterChildName (hasElemName "m" "e") element >>=
               elemToBase
    return [baseExp]
  elemToExps' element | isElem "m" "borderBox" element = do
    baseExp <- filterChildName (hasElemName "m" "e") element >>=
               elemToBase
    let bbPr = filterChildName (hasElemName "m" "borderBoxPr") element
        bltr = bbPr >>= filterChildName (hasElemName "m" "strikeBLTR") >>=
                        findAttrBy (hasElemName "m" "val")
        tlbr = bbPr >>= filterChildName (hasElemName "m" "strikeTLBR") >>=
                        findAttrBy (hasElemName "m" "val")
    return $
      case (bltr, tlbr) of
        (Just "1", Just "1") -> [ECancel XSlash baseExp]
        (Just "1", _)        -> [ECancel ForwardSlash baseExp]
        (_, Just "1")        -> [ECancel BackSlash baseExp]
        _                    -> [EBoxed baseExp]
  
  elemToExps' element | isElem "m" "d" element =
    let baseExps  = mapMaybe
                    elemToBases
                    (elChildren element)
        inDelimExps = map (map Right) baseExps
        dPr = filterChildName (hasElemName "m" "dPr") element
        headOrSpace [] = Just ' '
        headOrSpace (c:_) = Just c
        begChr = dPr >>=
                 filterChildName (hasElemName "m" "begChr") >>=
                 findAttrBy (hasElemName "m" "val") >>= headOrSpace
        sepChr = dPr >>=
                 filterChildName (hasElemName "m" "sepChr") >>=
                 findAttrBy (hasElemName "m" "val") >>= headOrSpace
        endChr = dPr >>=
                 filterChildName (hasElemName "m" "endChr") >>=
                 findAttrBy (hasElemName "m" "val") >>= headOrSpace
        beg = maybe "(" T.singleton begChr
        end = maybe ")" T.singleton endChr
        sep = maybe "|" T.singleton sepChr
        exps = intercalate [Left sep] inDelimExps
    in
     Just [EDelimited beg end exps]
  elemToExps' element | isElem "m" "eqArr" element =
    let expLst = mapMaybe elemToBases (elChildren element)
        expLst' = map breakOnAmpersand expLst
        cols = maximum (map length expLst')
        colspecs = take cols $ cycle [AlignRight , AlignLeft]
    in
     return [EArray colspecs expLst']
  elemToExps' element | isElem "m" "f" element = do
    num <- filterChildName (hasElemName "m" "num") element
    den <- filterChildName (hasElemName "m" "den") element
    let barType = filterChildName (hasElemName "m" "fPr") element >>=
              filterChildName (hasElemName "m" "type") >>=
              findAttrBy (hasElemName "m" "val")
    let numExp = EGrouped $ elemsToExps (elChildren num)
        denExp = EGrouped $ elemsToExps (elChildren den)
    case barType of
      Just "noBar" -> Just [EFraction NoLineFrac numExp denExp]
      _            -> Just [EFraction NormalFrac numExp denExp]
  elemToExps' element | isElem "m" "func" element = do
    fName <- filterChildName (hasElemName "m" "fName") element
    baseExp <- filterChildName (hasElemName "m" "e") element >>=
            elemToBase
    let fnameExp = case mconcat $ mapMaybe elemToExps' (elChildren fName) of
                     [x] -> x
                     xs  -> EGrouped xs
    return [fnameExp, baseExp]
  elemToExps' element | isElem "m" "groupChr" element = do
    let gPr = filterChildName (hasElemName "m" "groupChrPr") element
        chr = gPr >>=
              filterChildName (hasElemName "m" "chr") >>=
              findAttrBy (hasElemName "m" "val")
        pos = gPr >>=
              filterChildName (hasElemName "m" "pos") >>=
              findAttrBy (hasElemName "m" "val")
        justif = gPr >>=
                 filterChildName (hasElemName "m" "vertJC") >>=
                 findAttrBy (hasElemName "m" "val")
    baseExp <- filterChildName (hasElemName "m" "e") element >>=
               elemToBase
    case pos of
      Just "top" ->
        let chr' = case chr of
              Just (c:_) -> T.singleton c
              _           -> "\65079"   -- default to overbrace
        in
         return $
           case justif of
             Just "top" -> [EUnder False (ESymbol TOver chr') baseExp]
             _ -> [EOver False baseExp (ESymbol TOver chr')]
      _ -> -- bot is default
        let chr' = case chr of
              Just (c:_) -> T.singleton c
              _           -> "\65080"   -- default to underbrace
        in
         return $
           case justif of
             Just "top" -> [EUnder False baseExp (ESymbol TUnder chr')]
             _ -> [EOver False (ESymbol TUnder chr') baseExp]
  elemToExps' element | isElem "m" "limLow" element = do
    baseExp <- filterChildName (hasElemName "m" "e") element
            >>= elemToBase
    limExp <- filterChildName (hasElemName "m" "lim") element
              >>= (\e -> Just $ elemsToExps (elChildren e))
              >>= (return . EGrouped)
    return [EUnder True baseExp limExp]
  elemToExps' element | isElem "m" "limUpp" element = do
    baseExp <- filterChildName (hasElemName "m" "e") element
            >>= elemToBase
    limExp <- filterChildName (hasElemName "m" "lim") element
              >>= (\e -> Just $ elemsToExps (elChildren e))
              >>= (return . EGrouped)
    return [EOver True baseExp limExp]
  elemToExps' element | isElem "m" "m" element =
    let rows = filterChildrenName (hasElemName "m" "mr") element
        rowExps = map
                  (\mr -> mapMaybe
                          elemToBases
                          (elChildren mr))
                  rows
    in
     return [EArray [AlignCenter] rowExps]
  elemToExps' element | isElem "m" "nary" element = do
    let naryPr = filterChildName (hasElemName "m" "naryPr") element
        naryChr = naryPr >>=
                  filterChildName (hasElemName "m" "chr") >>=
                  findAttrBy (hasElemName "m" "val")
        opChr = case naryChr of
          Just (c:_) -> T.singleton c
          _          -> "\8747"   -- default to integral
        limLoc = naryPr >>=
                 filterChildName (hasElemName "m" "limLoc") >>=
                 findAttrBy (hasElemName "m" "val")
    subExps <- filterChildName (hasElemName "m" "sub") element >>=
           return . elemsToExps . elChildren
    supExps <- filterChildName (hasElemName "m" "sup") element >>=
           return . elemsToExps . elChildren
    let baseExp = maybeToList $
          filterChildName (hasElemName "m" "e") element >>= elemToBase
    case limLoc of
      Just "undOvr" -> return $ EUnderover True
                                (ESymbol Op opChr)
                                (EGrouped subExps)
                                (EGrouped supExps)
                              : baseExp
      _             -> return $ ESubsup
                                (ESymbol Op opChr)
                                (EGrouped subExps)
                                (EGrouped supExps)
                              : baseExp
  
  elemToExps' element | isElem "m" "phant" element = do
    baseExp <- filterChildName (hasElemName "m" "e") element >>=
               elemToBase
    return [EPhantom baseExp]
  elemToExps' element | isElem "m" "rad" element = do
    degExps <- filterChildName (hasElemName "m" "deg") element >>=
                return . elemsToExps . elChildren
    baseExp <- filterChildName (hasElemName "m" "e") element >>=
               elemToBase
    return $ case degExps of
      [] -> [ESqrt baseExp]
      ds -> [ERoot (EGrouped ds) baseExp]
  elemToExps' element | isElem "m" "sPre" element = do
    subExps <- filterChildName (hasElemName "m" "sub") element >>=
              return . elemsToExps . elChildren
    supExps <- filterChildName (hasElemName "m" "sup") element >>=
              return . elemsToExps . elChildren
    baseExp <- filterChildName (hasElemName "m" "e") element >>=
               elemToBase
    return [ESubsup
            (EIdentifier "")
            (EGrouped subExps)
            (EGrouped supExps)
           , baseExp]
  elemToExps' element | isElem "m" "sSub" element = do
    baseExp <- filterChildName (hasElemName "m" "e") element >>=
               elemToBase
    subExps <- filterChildName (hasElemName "m" "sub") element >>=
              return . elemsToExps . elChildren
    return [ESub baseExp (EGrouped subExps)]
  elemToExps' element | isElem "m" "sSubSup" element = do
    baseExp <- filterChildName (hasElemName "m" "e") element >>=
               elemToBase
    subExps <- filterChildName (hasElemName "m" "sub") element >>=
               return . elemsToExps . elChildren
    supExps <- filterChildName (hasElemName "m" "sup") element >>=
               return . elemsToExps . elChildren
    return [ESubsup baseExp (EGrouped subExps) (EGrouped supExps)]
  elemToExps' element | isElem "m" "sSup" element = do
    baseExp <- filterChildName (hasElemName "m" "e") element >>=
               elemToBase
    supExps <- filterChildName (hasElemName "m" "sup") element >>=
              return . elemsToExps . elChildren
    return [ESuper baseExp (EGrouped supExps)]
  elemToExps' element | isElem "m" "r" element = do
    let mrPr = filterChildName (hasElemName "m" "rPr") element
        lit = mrPr >>= filterChildName (hasElemName "m" "lit")
        nor = mrPr >>= filterChildName (hasElemName "m" "nor")
        txtSty = oMathRunTextStyleToTextType $ elemToOMathRunTextStyle element
    mrElems <- elemToOMathRunElems element
    return $
      if null lit && null nor
         then case txtSty of
                Nothing ->
                  interpretText $ oMathRunElemsToText mrElems
                Just textSty ->
                  [EStyled textSty $ interpretText $ oMathRunElemsToText mrElems]
         else [EText (fromMaybe TextNormal txtSty) $ oMathRunElemsToText mrElems]
  elemToExps' _ = Nothing
  
  interpretChar :: Char -> Exp
  interpretChar c | isDigit c = ENumber $ T.singleton c
  interpretChar c = case getSymbolType c of
    Alpha           -> EIdentifier c'
    Ord | isDigit c -> ENumber c'
        | otherwise -> case getSpaceWidth c of
                             Just x  -> ESpace x
                             Nothing -> ESymbol Ord c'
    symType         -> ESymbol symType c'
    where
      c' = T.singleton c
  
  interpretText :: T.Text -> [Exp]
  interpretText s
    | Just (c, xs) <- T.uncons s
    , T.null xs = [interpretChar c]
    | T.all isDigit s         = [ENumber s]
    | isJust (getOperator (EMathOperator s))
                            = [EMathOperator s]
    | otherwise             = map interpretChar (T.unpack s)
  
  -- The char attribute is a hex string
  getSymChar :: Element -> T.Text
  getSymChar element
    | Just s <- lowerFromPrivate <$> getCodepoint
    , Just font <- getFont =
    case readLitChar ("\\x" ++ s) of
       [(char, _)] -> maybe "" T.singleton $ getUnicode font char
       _ -> ""
    where
      getCodepoint = findAttrBy (hasElemName "w" "char") element
      getFont = (textToFont . T.pack) =<< findAttrBy (hasElemName "w" "font") element
      lowerFromPrivate ('F':xs) = '0':xs
      lowerFromPrivate xs = xs
  getSymChar _ = ""
  