pandoc-3.6: 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