path: root/src/Text/Pandoc/Readers/Typst/Math.hs

{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Text.Pandoc.Readers.Typst.Math
  ( pMathMany
  )
where

import Control.Monad (MonadPlus (mplus))
import Data.Char (isAlphaNum, isDigit)
import Data.List (intercalate)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Vector as V
import Text.Pandoc.Parsing ( many )
import Text.Pandoc.Class ( PandocMonad )
import Text.TeXMath.Types
  ( Alignment (..),
    Exp (..),
    FractionType (..),
    TeXSymbolType (..),
    TextType (..),
  )
import Text.TeXMath.Unicode.ToTeX (getSymbolType)
import Text.Pandoc.Readers.Typst.Parsing
    ( P, pTok, ignored, pWithContents, getField, chunks )
import Typst.Types

withGroup :: [Exp] -> Exp
withGroup [x] = x
withGroup xs = EGrouped xs

data AttachmentStyle = Limits | LimitsDisplay | Scripts
  deriving (Eq, Show)

getAttachmentStyle :: PandocMonad m => M.Map Identifier Val -> P m (Maybe AttachmentStyle)
getAttachmentStyle fields = do
  (base :: Seq Content) <- getField "base" fields
  case base of
    [Elt "math.op" _ fs] -> do
      limits <- getField "limits" fs
      if limits == VBoolean True
         then pure $ Just Limits
         else pure Nothing
    [Elt "math.limits" _ fs] -> do
      inl <- getField "inline" fs
      if inl == VBoolean False
         then pure $ Just LimitsDisplay
         else pure $ Just Limits
    [Elt "math.scripts" _ _] -> pure $ Just Scripts
    _ -> pure Nothing

pMath :: PandocMonad m => P m Exp
pMath = pTok (const True) >>= handleMath

handleMath :: PandocMonad m => Content -> P m Exp
handleMath tok =
  case tok of
    Lab t -> do
      ignored ("label " <> t)
      pure (EGrouped [])
    Txt t
      | T.any isDigit t -> pure $ ENumber t
      | T.length t == 1 ->
          case T.unpack t of
            [c] | not (isAlphaNum c) -> pure $ ESymbol (getSymbolType c) t
            _ -> pure $ EIdentifier t
      | otherwise -> pure $ EText TextNormal t
    Elt "math.dif" _ _ -> pure $ EIdentifier "d"
    Elt "math.Dif" _ _ -> pure $ EIdentifier "D"
    Elt "math.equation" _ fields -> getField "body" fields >>= pMathGrouped
    Elt "text" _ fields -> do
      body <- getField "body" fields
      (mbweight :: Maybe Text) <- getField "weight" fields
      case mbweight of
        Just "bold" -> EStyled TextBold <$> pMathMany body
        _ -> pMathGrouped body
    Elt "math.op" _ fields -> EMathOperator <$> getField "text" fields
    Elt "math.frac" _ fields -> do
      num <- getField "num" fields >>= pMathGrouped
      denom <- getField "denom" fields >>= pMathGrouped
      pure $ EFraction NormalFrac num denom
    Elt "math.accent" _ fields -> do
      base <- getField "base" fields >>= pMathGrouped
      acc <- getField "accent" fields >>= pMathGrouped
      let acc' = case acc of
            ESymbol _ "\8901" -> ESymbol Accent "\775" -- \dot
            ESymbol _ "\168" -> ESymbol Accent "\776" -- \ddot
            ESymbol _ "\8764" -> ESymbol Accent "\771" -- \tilde
            ESymbol _ t -> ESymbol Accent t
            _ -> acc
      pure $ EOver False base acc'
    Elt "math.attach" _ fields -> do
      base <- getField "base" fields >>= pMathGrouped
      t' <- getField "t" fields
      b' <- getField "b" fields
      tr' <- getField "tr" fields
      tl' <- getField "tl" fields
      br' <- getField "br" fields
      bl' <- getField "bl" fields
      attachmentStyle <- getAttachmentStyle fields
      let limits = case attachmentStyle of
                     Just Limits -> True
                     Just LimitsDisplay -> True
                     _ -> False
      let convertible = attachmentStyle == Just LimitsDisplay
      let (mbt, mbtr) =
            case (t', tr') of
              (Just top, Just topright) -> (Just top, Just topright)
              (Just top, Nothing)
                | limits -> (Just top, Nothing)
                | otherwise -> (Nothing, Just top)
              (Nothing, Just topright) -> (Nothing, Just topright)
              (Nothing, Nothing) -> (Nothing, Nothing)
      let (mbb, mbbr) =
            case (b', br') of
              (Just bot, Just botright) -> (Just bot, Just botright)
              (Just bot, Nothing)
                | limits -> (Just bot, Nothing)
                | otherwise -> (Nothing, Just bot)
              (Nothing, Just topright) -> (Nothing, Just topright)
              (Nothing, Nothing) -> (Nothing, Nothing)
      let dummy = EGrouped []
      let addPrefix x =
            case (tl', bl') of
              (Nothing, Nothing) -> pure x
              (Just top, Nothing) -> do
                res <- ESuper dummy <$> pMathGrouped top
                pure $ EGrouped [res, x]
              (Nothing, Just bot) -> do
                res <- ESub dummy <$> pMathGrouped bot
                pure $ EGrouped [res, x]
              (Just top, Just bot) -> do
                res <- ESubsup dummy <$> pMathGrouped bot <*> pMathGrouped top
                pure $ EGrouped [res, x]

      base' <- case (mbtr, mbbr) of
        (Nothing, Nothing) -> pure base
        (Nothing, Just br) -> ESub base <$> pMathGrouped br
        (Just tr, Nothing) -> ESuper base <$> pMathGrouped tr
        (Just tr, Just br) -> ESubsup base <$> pMathGrouped br <*> pMathGrouped tr

      suffix <- case (mbt, mbb) of
        (Nothing, Nothing) -> pure base'
        (Nothing, Just bot) -> EUnder convertible base' <$> pMathGrouped bot
        (Just top, Nothing) -> EOver convertible base' <$> pMathGrouped top
        (Just top, Just bot) -> EUnderover convertible base'
                                  <$> pMathGrouped bot <*> pMathGrouped top

      addPrefix suffix
    Elt "math.serif" _ fields ->
      EStyled TextNormal <$> (getField "body" fields >>= pMathMany)
    Elt "math.sans" _ fields ->
      EStyled TextSansSerif <$> (getField "body" fields >>= pMathMany)
    Elt "math.frak" _ fields ->
      EStyled TextFraktur <$> (getField "body" fields >>= pMathMany)
    Elt "math.mono" _ fields ->
      EStyled TextMonospace <$> (getField "body" fields >>= pMathMany)
    Elt "math.cal" _ fields ->
      EStyled TextScript <$> (getField "body" fields >>= pMathMany)
    Elt "math.bb" _ fields ->
      EStyled TextDoubleStruck <$> (getField "body" fields >>= pMathMany)
    Elt "math.upright" _ fields ->
      EStyled TextNormal <$> (getField "body" fields >>= pMathMany)
    Elt "math.bold" _ fields ->
      EStyled TextBold <$> (getField "body" fields >>= pMathMany)
    Elt "math.italic" _ fields ->
      EStyled TextItalic <$> (getField "body" fields >>= pMathMany)
    Elt "math.underline" _ fields ->
      EUnder False
        <$> (getField "body" fields >>= pMathGrouped)
        <*> pure (ESymbol TUnder "_")
    Elt "math.overline" _ fields ->
      EOver False
        <$> (getField "body" fields >>= pMathGrouped)
        <*> pure (ESymbol TOver "\175")
    Elt "math.underbrace" _ fields -> do
      mbAnn <- getField "annotation" fields
      body <- getField "body" fields >>= pMathGrouped
      let x = EUnder False body (ESymbol TUnder "\9183")
      case mbAnn of
        Nothing -> pure x
        Just ann -> EUnder False x <$> pMathGrouped ann
    Elt "math.overbrace" _ fields -> do
      mbAnn <- getField "annotation" fields
      body <- getField "body" fields >>= pMathGrouped
      let x = EOver False body (ESymbol TOver "\9182")
      case mbAnn of
        Nothing -> pure x
        Just ann -> EOver False x <$> pMathGrouped ann
    Elt "math.underbracket" _ fields -> do
      mbAnn <- getField "annotation" fields
      body <- getField "body" fields >>= pMathGrouped
      let x = EUnder False body (ESymbol TUnder "\9141")
      case mbAnn of
        Nothing -> pure x
        Just ann -> EUnder False x <$> pMathGrouped ann
    Elt "math.overbracket" _ fields -> do
      mbAnn <- getField "annotation" fields
      body <- getField "body" fields >>= pMathGrouped
      let x = EOver False body (ESymbol TOver "\9140")
      case mbAnn of
        Nothing -> pure x
        Just ann -> EOver False x <$> pMathGrouped ann
    Elt "math.underparen" _ fields -> do
      mbAnn <- getField "annotation" fields
      body <- getField "body" fields >>= pMathGrouped
      let x = EUnder False body (ESymbol TUnder "\9181")
      case mbAnn of
        Nothing -> pure x
        Just ann -> EUnder False x <$> pMathGrouped ann
    Elt "math.overparen" _ fields -> do
      mbAnn <- getField "annotation" fields
      body <- getField "body" fields >>= pMathGrouped
      let x = EOver False body (ESymbol TOver "\9180")
      case mbAnn of
        Nothing -> pure x
        Just ann -> EOver False x <$> pMathGrouped ann
    Elt "math.scripts" _ fields -> getField "body" fields >>= pMathGrouped
    Elt "math.limits" _ fields -> getField "body" fields >>= pMathGrouped
    Elt "math.root" _ fields -> do
      mbindex <- getField "index" fields
      radicand <- getField "radicand" fields >>= pMathGrouped
      case mbindex of
        Nothing -> pure $ ESqrt radicand
        Just index -> do
          index' <- pMathGrouped index
          pure $ ERoot index' radicand
    Elt "math.sqrt" _ fields ->
      ESqrt <$> (getField "radicand" fields >>= pMathGrouped)
    Elt "math.abs" _ fields -> do
      body <- getField "body" fields >>= pMathGrouped
      pure $ EDelimited "|" "|" [Right body]
    Elt "math.floor" _ fields -> do
      body <- getField "body" fields >>= pMathGrouped
      pure $ EDelimited "\8970" "\8971" [Right body]
    Elt "math.ceil" _ fields -> do
      body <- getField "body" fields >>= pMathGrouped
      pure $ EDelimited "\8968" "\8969" [Right body]
    Elt "math.norm" _ fields -> do
      body <- getField "body" fields >>= pMathGrouped
      pure $ EDelimited "\8214" "\8214" [Right body]
    Elt "math.round" _ fields -> do
      body <- getField "body" fields >>= pMathGrouped
      pure $ EDelimited "\8970" "\8969" [Right body]
    Elt "math.lr" _ fields -> do
      bodyparts <- getField "body" fields >>= mapM pMathMany . V.toList
      let rawbody = intercalate [ESymbol Pun ","] bodyparts
      let (op, rest) =
            case rawbody of
              (ESymbol _ t : xs) -> (t, xs)
              _ -> ("", rawbody)
      let (body, cl) =
            case reverse rest of
              (ESymbol _ t : _) -> (map Right (init rest), t)
              _ -> (map Right rest, "")
      pure $ EDelimited op cl body
    Elt "math.binom" _ fields -> do
      up <- getField "upper" fields >>= pMathGrouped
      low <- getField "lower" fields >>= pMathGrouped
      pure $ EDelimited "(" ")" [Right (EFraction NoLineFrac up low)]
    Elt "math.cases" _ fields -> do
      (delim :: Maybe Text) <- getField "delim" fields
      (children :: [Seq Content]) <-
        map valToContent . V.toList <$> getField "children" fields
      let isAlignPoint (Elt "math.alignpoint" _ _) = True
          isAlignPoint _ = False
      let formatRow vs = case Seq.breakl isAlignPoint vs of
            (xs, ys) -> do
              case Seq.viewl ys of
                _ Seq.:< rest -> do
                  xs' <- pMathMany xs
                  ys' <- pMathMany rest
                  pure [xs', ys']
                _ -> (: []) <$> pMathMany vs
      rows <- mapM formatRow children
      pure $
        EDelimited
          (fromMaybe "{" delim)
          ""
          [Right (EArray [AlignLeft, AlignLeft] rows)]
    Elt "math.vec" _ fields -> do
      (op, cl) <- arrayDelims fields
      rows <-
        getField "children" fields
          >>= mapM (fmap (: []) . pMathMany) . V.toList
      pure $
        EDelimited
          op
          cl
          [Right (EArray [AlignCenter] rows)]
    Elt "math.mat" _ fields -> do
      (op, cl) <- arrayDelims fields
      let formatCell x = do
            let content = valToContent x
            let align = case Seq.viewl content of
                  Elt "math.alignpoint" _ _ Seq.:< _ -> AlignLeft
                  _ -> case Seq.viewr content of
                    _ Seq.:> Elt "math.alignpoint" _ _ -> AlignRight
                    _ -> AlignCenter
            exp' <- pMathMany content
            pure (align, exp')
      let formatRow (VArray vs) = mapM formatCell (V.toList vs)
          formatRow _ = fail "mat expected array"
      (rawrows :: V.Vector Val) <- getField "rows" fields
      rows <- mapM formatRow (V.toList rawrows)
      let aligns =
            case rows of
              [] -> []
              (r : _) -> map fst r
      pure $
        EDelimited
          op
          cl
          [Right (EArray aligns (map (map snd) rows))]
    Elt "hide" _ fields -> do
      EPhantom <$> (getField "body" fields >>= pMathGrouped)
    Elt "h" _ fields -> do
      amount <- getField "amount" fields
      let em = case amount of
            LExact x LEm -> toRational x
            _ -> case amount <> LExact 0 LPt of -- force to Pt
              LExact x LPt -> toRational x / 12
              _ -> 1 / 3 -- guess!
      pure $ ESpace em
    Elt "grid" _ fields -> do
      children <- getField "children" fields >>= mapM pMathMany . V.toList
      (columns :: Val) <- getField "columns" fields
      numcols <- case columns of
        VInteger x -> pure $ fromIntegral x
        VArray x -> pure $ V.length x
        VNone -> pure 1
        _ -> fail $ "Could not determine number of columns: " <> show columns
      let rows = chunks numcols children
      pure $ EArray (replicate numcols AlignLeft) rows
    Elt "table" pos fields -> handleMath (Elt "grid" pos fields)
    Elt "link" _ fields -> do
      body <- getField "body" fields
      ignored "hyperlink in math"
      pMathGrouped body
    Elt "math.display" _ fields -> do
      content <- getField "content" fields
      ignored "display"
      pMathGrouped content
    Elt "math.inline" _ fields -> do
      content <- getField "content" fields
      ignored "inline"
      pMathGrouped content
    Elt "math.script" _ fields -> do
      content <- getField "content" fields
      ignored "script"
      pMathGrouped content
    Elt "math.sscript" _ fields -> do
      content <- getField "content" fields
      ignored "sscript"
      pMathGrouped content
    Elt (Identifier name) _ fields -> do
      body <- getField "body" fields `mplus` pure mempty
      ignored name
      pMathGrouped body

arrayDelims :: PandocMonad m => M.Map Identifier Val -> P m (Text, Text)
arrayDelims fields = do
  (mbdelim :: Maybe Text) <- getField "delim" fields
  pure $ case mbdelim of
    Just "(" -> ("(", ")")
    Just "[" -> ("[", "]")
    Just "{" -> ("{", "}")
    Just "|" -> ("|", "|")
    Just "||" -> ("\8741", "\8741")
    _ -> ("(", ")")

pMathMany :: PandocMonad m => Seq Content -> P m [Exp]
pMathMany cs = do
  -- check for "alignpoint" and "linebreak" elements
  -- and use an array structure for alignment
  let lns = splitOnLinebreaks cs
  case lns of
    [] -> pure []
    [ln] | not (any isAlignpoint ln) -> pWithContents (many pMath) ln
    _ -> do
      rows <- mapM (mapM (pWithContents (many pMath)) . splitOnAlignpoints) lns
      let numcols = maximum $ map length rows
      let cols = take numcols $ AlignRight : cycle [AlignLeft, AlignRight]
      pure [EArray cols rows]

pMathGrouped :: PandocMonad m => Seq Content -> P m Exp
pMathGrouped = fmap withGroup . pMathMany

splitOnLinebreaks :: Seq Content -> [Seq Content]
splitOnLinebreaks xs =
  if Seq.null bs
    then
      if null as
        then []
        else [as]
    else as : splitOnLinebreaks (Seq.drop 1 bs)
  where
    (as, bs) = Seq.breakl isLinebreak xs
    isLinebreak (Elt "linebreak" _ _) = True
    isLinebreak _ = False

splitOnAlignpoints :: Seq Content -> [Seq Content]
splitOnAlignpoints xs =
  if Seq.null bs
    then
      if null as
        then []
        else [as]
    else as : splitOnAlignpoints (Seq.drop 1 bs)
  where
    (as, bs) = Seq.breakl isAlignpoint xs

isAlignpoint :: Content -> Bool
isAlignpoint (Elt "math.alignpoint" _ _) = True
isAlignpoint _ = False