pandoc-3.12: src/Text/Pandoc/Readers/Typst.hs
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}
{- |
Module : Text.Pandoc.Readers.Typst
Copyright : Copyright (C) 2023 John MacFarlane
License : GNU GPL, version 2 or above
Maintainer : John MacFarlane <jgm@berkeley.edu>
Stability : alpha
Portability : portable
Reads and evaluates a Typst document as a Pandoc AST.
-}
module Text.Pandoc.Readers.Typst
( readTypst
)
where
import Text.Pandoc.Class
import Text.Pandoc.Sources
import Text.Pandoc.Options
import Text.Pandoc.Definition
import Typst ( parseTypst, evaluateTypst )
import Text.Pandoc.Error (PandocError(..))
import Text.Pandoc.Translations (Term(References), translateTerm)
import Text.Pandoc.Shared (tshow, blocksToInlines, compactifyTable)
import Text.Pandoc.Parsing (registerHeader, reportLogMessages)
import Control.Monad.Except (throwError)
import Control.Monad (MonadPlus (mplus), void, guard, foldM)
import Control.Monad.Trans (lift)
import qualified Data.Foldable as F
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Walk
import Text.Parsec
import Text.TeXMath (writeTeX)
import Text.TeXMath.Shared (getSpaceChars)
import Text.Pandoc.Readers.Typst.Math (pMathMany)
import Text.Pandoc.Readers.Typst.Parsing (pTok, ignored, getField, P,
PState(..), defaultPState)
import Typst.Methods (formatNumber, applyPureFunction)
import Typst.Types
import qualified Data.Vector as V
import System.FilePath (takeDirectory)
import qualified System.FilePath.Windows as Windows
import qualified System.FilePath.Posix as Posix
-- | Read Typst from an input string and return a Pandoc document.
readTypst :: (PandocMonad m, ToSources a)
=> ReaderOptions -> a -> m Pandoc
readTypst opts inp = do
let sources = toSources inp
let inputName = case sources of
Sources ((pos, _):_) -> sourceName pos
_ -> ""
case parseTypst inputName (sourcesToText sources) of
Left e -> throwError $ PandocParseError $ T.pack $ show e
Right parsed -> do
let ops = Operations {
loadBytes = readFileStrict,
currentUTCTime = getCurrentTime,
lookupEnvVar = fmap (fmap T.unpack) . lookupEnv . T.pack,
checkExistence = fileExists }
res <- evaluateTypst ops (readerTypstInputs opts) inputName parsed
case res of
Left e -> throwError $ PandocParseError $ tshow e
Right content -> do
let content' = fixNesting content
let labs = findLabels [content']
runParserT pPandoc defaultPState{ sLabels = labs, sOptions = opts }
inputName [content'] >>=
either (throwError . PandocParseError . T.pack . show) pure
pBlockElt :: PandocMonad m => P m B.Blocks
pBlockElt = try $ do
res <- pTok (\t -> isBlock t || not (isInline t))
-- check for following label
mbident <- option Nothing $ Just <$> pLab
case res of
Elt name@(Identifier tname) pos fields -> do
case M.lookup name blockHandlers of
Nothing -> do
ignored ("unknown block element " <> tname <>
" at " <> tshow pos)
pure mempty
Just (BlockHandler handler) -> handler pos mbident fields
_ -> pure mempty
pInline :: PandocMonad m => P m B.Inlines
pInline = try $ do
res <- pTok (\t -> isInline t || not (isBlock t))
case res of
Txt t -> pure $ B.text t
Lab name -> pure $ B.spanWith (name, [], []) mempty
Elt (Identifier tname) _ _
| "math." `T.isPrefixOf` tname
, tname /= "math.equation" ->
B.math . writeTeX <$> pMathMany (Seq.singleton res)
Elt name@(Identifier tname) pos fields -> do
let runInlineHandler =
case M.lookup name inlineHandlers of
Nothing -> do
ignored ("unknown inline element " <> tname <>
" at " <> tshow pos)
pure mempty
Just (InlineHandler handler) -> handler pos Nothing fields
if tname /= "ref"
then runInlineHandler
else do
labs <- sLabels <$> getState
labelTarget <- (do result <- getField "target" fields
case result of
VLabel t | t `Set.member` labs -> pure True
_ -> pure False)
<|> pure False
if labelTarget
then runInlineHandler
else do
-- @foo is a citation unless it links to a lab in the doc:
let targetToKey (Identifier "target") = Identifier "key"
targetToKey k = k
case M.lookup "cite" inlineHandlers of
Nothing -> do
ignored ("unknown inline element " <> tname <>
" at " <> tshow pos)
pure mempty
Just (InlineHandler handler) ->
handler pos Nothing (M.mapKeys targetToKey fields)
-- Ensure that inline elements contain only inline content: split
-- them at paragraph breaks, and pull block children out, applying the
-- element to a child's own contents (#11017, #11881). A pandoc inline
-- cannot span paragraphs, so this is the closest structural rendering;
-- e.g. Elt "emph" [Txt "hi", parbreak, Txt "there"] becomes
-- Elt "emph" [Txt "hi"], parbreak, Elt "emph" [Txt "there"].
fixNesting :: Content -> Content
fixNesting el@(Elt name _ _)
| Identifier tname <- name
, "math." `T.isPrefixOf` tname = el -- math has its own grammar
fixNesting (Elt name pos fields) = Elt name pos (M.map fixVal fields)
fixNesting x = x
fixVal :: Val -> Val
fixVal (VContent cs) = VContent (fixSeq cs)
fixVal (VArray vs) = VArray (fmap fixVal vs)
fixVal (VTermItem t d) = VTermItem (fixSeq t) (fixSeq d)
fixVal v = v
fixSeq :: Seq Content -> Seq Content
fixSeq = foldMap expand . fmap fixNesting
-- Split an inline element whose body contains block content.
expand :: Content -> Seq Content
expand el@(Elt name pos fields)
| isSplittable name
, Just (field, VContent body) <- contentField fields
, F.any isStrictlyBlock body
= splitInlineBody name pos fields field body
| otherwise = Seq.singleton el
expand x = Seq.singleton x
-- Whether the element's body is parsed with pInlines, and thus cannot
-- contain block content: anything without a block handler, except
-- footnote (body parsed as blocks), the block-body table elements, and
-- math elements.
isSplittable :: Identifier -> Bool
isSplittable name@(Identifier tname) =
name `Set.notMember` blockKeys
&& name `Set.notMember` blockBodyElements
&& not ("math." `T.isPrefixOf` tname)
-- Elements without block handlers whose content is nonetheless parsed
-- as block content.
blockBodyElements :: Set.Set Identifier
blockBodyElements = Set.fromList
[ "footnote", "grid.cell", "table.cell", "grid.header"
, "table.header", "grid.footer", "table.footer" ]
-- Strictly block content, not consumable by 'pInline'.
isStrictlyBlock :: Content -> Bool
isStrictlyBlock c = isBlock c && not (isInline c)
-- The element's content field. Only body and text: other content
-- fields, such as ref's supplement, are parameters rather than bodies.
contentField :: M.Map Identifier Val -> Maybe (Identifier, Val)
contentField fields =
listToMaybe
[ kv | kv@(k, VContent _) <- M.toAscList fields
, k == Identifier "body" || k == Identifier "text" ]
-- Split the element's body at block content: inline runs are wrapped
-- back in the element, a parbreak separates paragraphs, and a block
-- child gets the element applied to its own body, if it has one.
splitInlineBody
:: Identifier -> Maybe SourcePos -> M.Map Identifier Val
-> Identifier -> Seq Content -> Seq Content
splitInlineBody name pos fields field =
Seq.fromList . go [] . F.toList
where
wrap cs = Elt name pos (M.insert field (VContent (Seq.fromList cs)) fields)
go run [] = flush run
go run (c : cs)
| isStrictlyBlock c = flush run ++ splitOff c ++ go [] cs
| otherwise = go (c : run) cs
flush run = [ wrap (reverse run) | not (null run) ]
splitOff c
| isParbreak c = [Elt "parbreak" pos mempty]
| otherwise = case c of
Elt bname bpos bfields
| Just (VContent inner) <- M.lookup (Identifier "body") bfields ->
[ Elt bname bpos
( M.insert (Identifier "body")
(VContent (expand (wrap (F.toList inner))))
bfields ) ]
_ -> [c]
isParbreak :: Content -> Bool
isParbreak (Elt "parbreak" _ _) = True
isParbreak _ = False
pPandoc :: PandocMonad m => P m B.Pandoc
pPandoc = do
Elt "document" _ fields <- pTok isDocument
bs <- getField "body" fields >>= pWithContents pBlocks
title <- (getField "title" fields >>= pWithContents pInlines) <|>
pure mempty
authors <- (getField "author" fields >>=
mapM (pWithContents pInlines) . V.toList) <|>
((:[]) <$> (getField "author" fields >>=
(\x -> guard (not (null x)) *>
pWithContents pInlines x))) <|>
pure []
date <- (getField "date" fields >>= pWithContents pInlines) <|>
pure mempty
keywords <- (getField "keywords" fields >>=
mapM (pWithContents pInlines) . V.toList)
<|> pure []
meta <- sMeta <$> getState
let meta' =
(if title == mempty || isJust (lookupMeta "title" meta)
then id
else B.setMeta "title" title) .
(if null authors
then id
else B.setMeta "author" authors) .
(if null date
then id
else B.setMeta "date" date) .
(if null keywords
then id
else B.setMeta "keywords" keywords) $ meta
reportLogMessages
pure $ Pandoc meta' (B.toList bs)
pBlocks :: PandocMonad m => P m B.Blocks
pBlocks = mconcat <$> many pBlock
pBlock :: PandocMonad m => P m B.Blocks
pBlock = pPara <|> pBlockElt
pSpace :: PandocMonad m => P m Content
pSpace = pTok
( \case
Txt t | T.all (== ' ') t -> True
_ -> False )
pLab :: PandocMonad m => P m Text
pLab = try $ do
optional pSpace
Lab t <- pTok
( \case
Lab _ -> True
_ -> False
)
pure t
isDocument :: Content -> Bool
isDocument (Elt "document" _ _) = True
isDocument _ = False
isBlock :: Content -> Bool
isBlock (Elt "raw" _ fields) = M.lookup "block" fields == Just (VBoolean True)
isBlock (Elt name _ _) = name `Set.member` blockKeys
isBlock Lab{} = True
isBlock _ = False
isInline :: Content -> Bool
isInline (Elt "raw" _ fields) = M.lookup "block" fields /= Just (VBoolean True)
isInline (Elt name _ _) = name `Set.member` inlineKeys
isInline Lab{} = True
isInline Txt{} = True
blockKeys :: Set.Set Identifier
blockKeys = Set.fromList $ M.keys blockHandlers
inlineKeys :: Set.Set Identifier
inlineKeys = Set.fromList $ M.keys inlineHandlers
-- The handler maps are wrapped in newtypes with polymorphic fields so
-- that the maps themselves are monomorphic. This guarantees that they
-- are constant applicative forms, constructed only once; a
-- @PandocMonad m => M.Map ...@ would be a function taking a typeclass
-- dictionary, liable to be rebuilt at each lookup.
newtype BlockHandler = BlockHandler
(forall m. PandocMonad m
=> Maybe SourcePos -> Maybe Text -> M.Map Identifier Val
-> P m B.Blocks)
newtype InlineHandler = InlineHandler
(forall m. PandocMonad m
=> Maybe SourcePos -> Maybe Text -> M.Map Identifier Val
-> P m B.Inlines)
blockHandlers :: M.Map Identifier BlockHandler
blockHandlers = M.fromList
[("text", BlockHandler $ \_ _ fields -> do
body <- getField "body" fields
-- sometimes text elements include para breaks
notFollowedBy $ void $ pWithContents pInlines body
pWithContents pBlocks body)
,("title", BlockHandler $ \_ _ fields -> do
body <- getField "body" fields
case body of
VContent cs -> do
ils <- pWithContents pInlines cs <|> pure mempty
updateState $ \s -> s{ sMeta = B.setMeta "title" ils (sMeta s) }
pure mempty
_ -> pure mempty)
,("box", BlockHandler $ \_ _ fields -> do
body <- getField "body" fields
B.divWith ("", ["box"], []) <$> pWithContents pBlocks body)
,("heading", BlockHandler $ \_ mbident fields -> do
body <- getField "body" fields
lev <- getField "level" fields <|> pure 1
ils <- pWithContents pInlines body
attr <- registerHeader (fromMaybe "" mbident,[],[]) ils
pure $ B.headerWith attr lev ils)
,("quote", BlockHandler $ \_ _ fields -> do
getField "block" fields >>= guard
body <- getField "body" fields >>= pWithContents pBlocks
attribution' <- getField "attribution" fields
attribution <- if attribution' == mempty
then pure mempty
else (\x -> B.para ("\x2014\xa0" <> x)) <$>
(pWithContents pInlines attribution')
pure $ B.blockQuote $ body <> attribution)
,("list", BlockHandler $ \_ _ fields -> do
children <- V.toList <$> getField "children" fields
B.bulletList <$> mapM (pWithContents pBlocks) children)
,("list.item", BlockHandler $ \_ _ fields -> getField "body" fields >>= pWithContents pBlocks)
,("enum", BlockHandler $ \_ _ fields -> do
children <- V.toList <$> getField "children" fields
mbstart <- getField "start" fields
start <- case mbstart of
Nothing -> pure 1
Just x
| x >= 0 -> pure x
| otherwise -> fail "number must be positive"
(numbering :: Text) <- getField "numbering" fields `mplus` pure ""
let (sty, delim) =
case numbering of
"1." -> (B.Decimal, B.Period)
"1)" -> (B.Decimal, B.OneParen)
"(1)" -> (B.Decimal, B.TwoParens)
"a." -> (B.LowerAlpha, B.Period)
"a)" -> (B.LowerAlpha, B.OneParen)
"(a)" -> (B.LowerAlpha, B.TwoParens)
"A." -> (B.UpperAlpha, B.Period)
"A)" -> (B.UpperAlpha, B.OneParen)
"(A)" -> (B.UpperAlpha, B.TwoParens)
"i." -> (B.LowerRoman, B.Period)
"i)" -> (B.LowerRoman, B.OneParen)
"(i)" -> (B.LowerRoman, B.TwoParens)
"I." -> (B.UpperRoman, B.Period)
"I)" -> (B.UpperRoman, B.OneParen)
"(I)" -> (B.UpperRoman, B.TwoParens)
_ -> (B.DefaultStyle, B.DefaultDelim)
let listAttr = (start, sty, delim)
B.orderedListWith listAttr <$> mapM (pWithContents pBlocks) children)
,("enum.item", BlockHandler $ \_ _ fields -> getField "body" fields >>= pWithContents pBlocks)
,("terms", BlockHandler $ \_ _ fields -> do
children <- V.toList <$> getField "children" fields
B.definitionList
<$> mapM
( \case
VTermItem t d -> do
t' <- pWithContents pInlines t
d' <- pWithContents pBlocks d
pure (t', [d'])
_ -> pure (mempty, [])
)
children)
,("terms.item", BlockHandler $ \_ _ fields -> getField "body" fields >>= pWithContents pBlocks)
,("raw", BlockHandler $ \_ mbident fields -> do
txt <- T.filter (/= '\r') <$> getField "text" fields
mblang <- getField "lang" fields
let attr = (fromMaybe "" mbident, maybe [] (\l -> [l]) mblang, [])
pure $ B.codeBlockWith attr txt)
,("parbreak", BlockHandler $ \_ _ _ -> pure mempty)
,("par", BlockHandler $ \_ mbident fields -> do
maybe B.para (\ident -> B.divWith (ident, [], []) . B.para) mbident
<$> (getField "body" fields >>= pWithContents pInlines))
,("block", BlockHandler $ \_ mbident fields ->
maybe id (\ident -> B.divWith (ident, [], [])) mbident
<$> (getField "body" fields >>= pWithContents pBlocks))
,("place", BlockHandler $ \_ _ fields -> do
ignored "parameters of place"
getField "body" fields >>= pWithContents pBlocks)
,("columns", BlockHandler $ \_ _ fields -> do
(cnt :: Integer) <- getField "count" fields
B.divWith ("", ["columns-flow"], [("count", T.pack (show cnt))])
<$> (getField "body" fields >>= pWithContents pBlocks))
,("rect", BlockHandler $ \_ _ fields ->
B.divWith ("", ["rect"], []) <$> (getField "body" fields >>= pWithContents pBlocks))
,("circle", BlockHandler $ \_ _ fields ->
B.divWith ("", ["circle"], []) <$> (getField "body" fields >>= pWithContents pBlocks))
,("ellipse", BlockHandler $ \_ _ fields ->
B.divWith ("", ["ellipse"], []) <$> (getField "body" fields >>= pWithContents pBlocks))
,("polygon", BlockHandler $ \_ _ fields ->
B.divWith ("", ["polygon"], []) <$> (getField "body" fields >>= pWithContents pBlocks))
,("square", BlockHandler $ \_ _ fields ->
B.divWith ("", ["square"], []) <$> (getField "body" fields >>= pWithContents pBlocks))
,("align", BlockHandler $ \_ _ fields -> do
alignment <- getField "alignment" fields
B.divWith ("", [], [("align", repr alignment)])
<$> (getField "body" fields >>= pWithContents pBlocks))
,("stack", BlockHandler $ \_ _ fields -> do
(dir :: Direction) <- getField "dir" fields `mplus` pure Ltr
rawchildren <- getField "children" fields
children <-
mapM
( \case
val@(VFraction {}) ->
pure $ B.divWith ("", [], [("space", repr val)]) mempty
val -> fromVal val >>= pWithContents pBlocks
)
(V.toList rawchildren)
pure $
B.divWith ("", [], [("stack", repr (VDirection dir))]) $
mconcat $
map (B.divWith ("", [], [])) children)
,("grid", BlockHandler $ \_ mbident fields -> parseTable mbident fields)
,("table", BlockHandler $ \_ mbident fields -> parseTable mbident fields)
,("figure", BlockHandler $ \_ mbident fields -> do
body <- getField "body" fields >>= pWithContents pBlocks
(mbCaption :: Maybe (Seq Content)) <- getField "caption" fields
(caption :: B.Blocks) <- maybe mempty (pWithContents pBlocks) mbCaption
pure $ case B.toList body of
[B.Table attr _ colspecs thead tbodies tfoot] ->
B.singleton
(B.Table attr (B.Caption Nothing (B.toList caption)) colspecs thead tbodies tfoot)
_ -> B.figureWith (fromMaybe "" mbident, [], [])
(B.Caption Nothing (B.toList caption)) body)
,("line", BlockHandler $ \_ _ fields ->
case ( M.lookup "start" fields
>> M.lookup "end" fields
>> M.lookup "angle" fields ) of
Nothing -> pure B.horizontalRule
_ -> pure mempty)
,("divider", BlockHandler $ \_ _ _fields -> pure B.horizontalRule)
,("numbering", BlockHandler $ \_ _ fields -> do
numStyle <- getField "numbering" fields
(nums :: V.Vector Integer) <- getField "numbers" fields
let toText v = fromMaybe "" $ fromVal v
let toNum n =
case numStyle of
VString t -> formatNumber t (fromIntegral n)
VFunction _ _ f ->
case applyPureFunction f [VInteger n] of
Success x -> toText x
Failure _ -> "?"
_ -> "?"
pure $ B.plain . B.text . mconcat . map toNum $ V.toList nums)
,("footnote.entry", BlockHandler $ \_ _ fields ->
getField "body" fields >>= pWithContents pBlocks)
,("pad", BlockHandler $ \_ _ fields -> -- ignore paddingy
getField "body" fields >>= pWithContents pBlocks)
,("pagebreak", BlockHandler $ \_ _ _ -> pure $ B.divWith ("", ["page-break"], [("wrapper", "1")]) B.horizontalRule)
,("bibliography", BlockHandler $ \_ _ fields -> do
let getSources v = case v of
VString t -> MetaString t
VArray xs -> MetaList $ map getSources $ V.toList xs
_ -> MetaBool True -- should not occur
let mbSources = getSources <$> M.lookup "sources" fields
let updateBibliography x = updateState $ \s ->
s{ sMeta = B.setMeta "bibliography" x (sMeta s) }
maybe (pure ()) updateBibliography mbSources
let title' = M.lookup "title" fields
mbTitle <- case title' of
Just VNone -> pure Nothing
Just (VContent cs) -> Just <$> pWithContents pInlines cs
Just (VString t) -> pure $ Just $ B.text t
_ -> Just . B.text <$> lift (translateTerm References)
let hdr = maybe mempty (B.header 1) mbTitle
pure $ hdr <> B.divWith ("refs", [], []) mempty)
,("rotate", BlockHandler $ \_ _ fields -> do
body <- getField "body" fields >>= pWithContents pBlocks
let kvs = case M.lookup "angle" fields of
Just (VAngle ang) -> [("angle", T.pack $ show ang)]
_ -> []
pure $ B.divWith ("", ["rotate"], kvs) body)
]
inlineHandlers :: M.Map Identifier InlineHandler
inlineHandlers = M.fromList
[("ref", InlineHandler $ \_ _ fields -> do
VLabel target <- getField "target" fields
supplement' <- getField "supplement" fields
supplement <- case supplement' of
VAuto -> -- TODO for now, until we can locate the element
pure $ B.text ("[" <> target <> "]")
VContent cs -> pWithContents pInlines cs
VFunction _ _ _f -> -- TODO for now, until we can locate the element
pure $ B.text ("[" <> target <> "]")
_ -> pure mempty
pure $ B.linkWith ("", ["ref"], []) ("#" <> target) "" supplement)
,("linebreak", InlineHandler $ \_ _ _ -> pure B.linebreak)
,("text", InlineHandler $ \_ _ fields -> do
body <- getField "body" fields
(mbweight :: Maybe Text) <- getField "weight" fields
case mbweight of
Just "bold" -> B.strong <$> pWithContents pInlines body
_ -> pWithContents pInlines body)
,("raw", InlineHandler $ \_ _ fields -> B.code . T.filter (/= '\r') <$> getField "text" fields)
,("footnote", InlineHandler $ \_ _ fields ->
B.note <$> (getField "body" fields >>= pWithContents pBlocks))
,("cite", InlineHandler $ \_ _ fields -> do
VLabel key <- getField "key" fields
(form :: Text) <- getField "form" fields <|> pure "normal"
let citation =
B.Citation
{ B.citationId = key,
B.citationPrefix = mempty,
B.citationSuffix = mempty,
B.citationMode = case form of
"prose" -> B.AuthorInText
"year" -> B.SuppressAuthor
-- "author" and "full" have no pandoc
-- equivalent; fall back to normal
_ -> B.NormalCitation,
B.citationNoteNum = 0,
B.citationHash = 0
}
pure $ B.cite [citation] (B.text $ "[" <> key <> "]"))
,("lower", InlineHandler $ \_ _ fields -> do
body <- getField "text" fields
walk (modString T.toLower) <$> pWithContents pInlines body)
,("upper", InlineHandler $ \_ _ fields -> do
body <- getField "text" fields
walk (modString T.toUpper) <$> pWithContents pInlines body)
,("emph", InlineHandler $ \_ _ fields -> do
body <- getField "body" fields
B.emph <$> pWithContents pInlines body)
,("strong", InlineHandler $ \_ _ fields -> do
body <- getField "body" fields
B.strong <$> pWithContents pInlines body)
,("sub", InlineHandler $ \_ _ fields -> do
body <- getField "body" fields
B.subscript <$> pWithContents pInlines body)
,("super", InlineHandler $ \_ _ fields -> do
body <- getField "body" fields
B.superscript <$> pWithContents pInlines body)
,("strike", InlineHandler $ \_ _ fields -> do
body <- getField "body" fields
B.strikeout <$> pWithContents pInlines body)
,("smallcaps", InlineHandler $ \_ _ fields -> do
body <- getField "body" fields
B.smallcaps <$> pWithContents pInlines body)
,("underline", InlineHandler $ \_ _ fields -> do
body <- getField "body" fields
B.underline <$> pWithContents pInlines body)
,("highlight", InlineHandler $ \_ _ fields -> do
body <- getField "body" fields
B.spanWith ("", ["mark"], []) <$> pWithContents pInlines body)
,("quote", InlineHandler $ \_ _ fields -> do
(getField "block" fields <|> pure False) >>= guard . not
body <- getField "body" fields >>= pWithContents pInlines
pure $ B.doubleQuoted $ B.trimInlines body)
,("link", InlineHandler $ \_ _ fields -> do
dest <- getField "dest" fields
src <- case dest of
VString t -> pure t
VLabel t -> pure $ "#" <> t
VDict _ -> do
ignored "link to location, linking to #"
pure "#"
_ -> fail "Expected string or label for dest"
body <- getField "body" fields
description <-
if null body
then
pure $
B.text $
if "mailto:" `T.isPrefixOf` src
then T.drop 7 src
else
if "tel:" `T.isPrefixOf` src
then T.drop 4 src
else src
else pWithContents pInlines body <|>
pWithContents
(B.fromList . blocksToInlines . B.toList <$> pBlocks) body
pure $ B.link src "" description)
,("image", InlineHandler $ \mbpos _ fields -> do
path <- getField "source" fields <|> getField "path" fields
alt <- (B.text <$> getField "alt" fields) `mplus` pure mempty
let basedir = maybe "." (takeDirectory . sourceName) mbpos
let isAbsolutePath p = Posix.isAbsolute p || Windows.isAbsolute p
let path' = T.pack $
if isAbsolutePath path || basedir == "."
then path
else basedir Posix.</> path
(mbwidth :: Maybe Text) <-
fmap (renderLength False) <$> getField "width" fields
(mbheight :: Maybe Text) <-
fmap (renderLength False) <$> getField "height" fields
let attr =
( "",
[],
maybe [] (\x -> [("width", x)]) mbwidth
++ maybe [] (\x -> [("height", x)]) mbheight
)
pure $ B.imageWith attr path' "" alt)
,("box", InlineHandler $ \_ _ fields -> do
body <- getField "body" fields
B.spanWith ("", ["box"], []) <$> pWithContents pInlines body)
,("h", InlineHandler $ \_ _ fields -> do
amount <- getField "amount" fields `mplus` pure (LExact 1 LEm)
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 $ B.text $ getSpaceChars em)
,("place", InlineHandler $ \_ _ fields -> do
ignored "parameters of place"
getField "body" fields >>= pWithContents pInlines)
,("align", InlineHandler $ \_ _ fields -> do
alignment <- getField "alignment" fields
B.spanWith ("", [], [("align", repr alignment)])
<$> (getField "body" fields >>= pWithContents pInlines))
,("sys.version", InlineHandler $ \_ _ _ -> pure $ B.text "typst-hs")
,("math.equation", InlineHandler $ \_ _ fields -> do
body <- getField "body" fields
display <- getField "block" fields
(if display then B.displayMath else B.math) . writeTeX <$> pMathMany body)
,("pad", InlineHandler $ \_ _ fields -> -- ignore paddingy
getField "body" fields >>= pWithContents pInlines)
,("rotate", InlineHandler $ \_ _ fields -> do
body <- getField "body" fields >>= pWithContents pInlines
let kvs = case M.lookup "angle" fields of
Just (VAngle ang) -> [("angle", T.pack $ show ang)]
_ -> []
pure $ B.spanWith ("", ["rotate"], kvs) body)
]
pPara :: PandocMonad m => P m B.Blocks
pPara = do
ils <- B.trimInlines . collapseAdjacentCites . mconcat <$> many1 pInline
optional pParBreak
pure $ if ils == mempty
then mempty
else B.para ils
pParBreak :: PandocMonad m => P m ()
pParBreak =
void $
pTok
( \case
Elt "parbreak" _ _ -> True
_ -> False
)
pWithContents :: PandocMonad m => P m a -> Seq Content -> P m a
pWithContents pa cs = try $ do
inp <- getInput
setInput $ F.toList cs
res <- pa
eof
setInput inp
pure res
pInlines :: PandocMonad m => P m B.Inlines
pInlines =
mappend <$> (collapseAdjacentCites . mconcat <$> many pInline)
<*> ((B.softbreak <$ pParBreak) <|> pure mempty)
collapseAdjacentCites :: B.Inlines -> B.Inlines
collapseAdjacentCites = B.fromList . foldr go [] . B.toList
where
go (Cite cs1 ils1) (Cite cs2 ils2 : xs) =
Cite (cs1 ++ cs2) (ils1 <> ils2) : xs
go (Cite cs1 ils1) (Space : Cite cs2 ils2 : xs) =
Cite (cs1 ++ cs2) (ils1 <> ils2) : xs
go (Cite cs1 ils1) (SoftBreak : Cite cs2 ils2 : xs) =
Cite (cs1 ++ cs2) (ils1 <> ils2) : xs
go x xs = x:xs
modString :: (Text -> Text) -> B.Inline -> B.Inline
modString f (B.Str t) = B.Str (f t)
modString _ x = x
findLabels :: Seq.Seq Content -> Set.Set Text
findLabels = F.foldl' go Set.empty
where
go acc Txt{} = acc
go acc (Lab t) = Set.insert t acc
go acc (Elt{ eltFields = fs }) = F.foldl' go' acc fs
go' acc (VContent cs) = F.foldl' go acc cs
go' acc _ = acc
parseTable :: PandocMonad m
=> Maybe Text -> M.Map Identifier Val -> P m B.Blocks
parseTable mbident fields = do
children <- V.toList <$> getField "children" fields
(columns :: Val) <- getField "columns" fields
let toWidth (VFraction f) = Just (floor $ 1000 * f)
toWidth _ = Nothing
let normalizeWidths xs =
let givenwidths = catMaybes xs
(totgivenwidth :: Int) = sum givenwidths
avgwidth = totgivenwidth `div` length givenwidths
totwidth = avgwidth * length xs
in if null givenwidths
then replicate (length xs) B.ColWidthDefault
else
map
( \case
Just x ->
B.ColWidth (fromIntegral x / fromIntegral totwidth)
Nothing ->
B.ColWidth
(fromIntegral avgwidth / fromIntegral totwidth)
)
xs
widths <- case columns of
VInteger x -> pure $ replicate (fromIntegral x) B.ColWidthDefault
VArray x -> pure $ normalizeWidths $ map toWidth (V.toList x)
VNone -> pure [B.ColWidthDefault]
_ -> fail $ "Could not determine number of columns: " <> show columns
let numcols = length widths
align <- getField "align" fields
let toAlign (VAlignment (Just horiz) _) =
case horiz of
HorizStart -> B.AlignLeft
HorizLeft -> B.AlignLeft
HorizEnd -> B.AlignRight
HorizRight -> B.AlignRight
HorizCenter -> B.AlignCenter
toAlign _ = B.AlignDefault
aligns <-
case align of
VAlignment {} -> pure $ replicate numcols (toAlign align)
VArray v -> pure $ map toAlign (V.toList v)
VFunction _ _ f -> do
mapM
( \colnum -> case applyPureFunction
f
[VInteger colnum, VInteger 0] of
Success x -> pure $ toAlign x
Failure e -> fail e
)
[0 .. (fromIntegral numcols - 1)]
_ -> pure $ replicate numcols B.AlignDefault
let colspecs = zip (aligns ++ repeat B.AlignDefault) widths
let addCell' cell Nothing = addCell' cell (Just ([], []))
addCell' cell@(B.Cell _ _ (B.RowSpan rowspan) (B.ColSpan colspan) _)
(Just (freecols, revrows)) =
let freecols' =
case (rowspan + 1) - length freecols of
n | n < 0 -> freecols
| otherwise -> freecols ++ replicate n numcols
in case freecols' of
[] -> -- should not happen
error "empty freecols'"
x:xs
| colspan <= x -- there is room on current row
-> let (as, bs) = splitAt rowspan (x:xs)
in Just
(map (\z -> z - colspan) as ++ bs,
case revrows of
[] -> [[cell]]
r:rs -> (cell:r):rs)
| otherwise ->
let (as, bs) = splitAt rowspan xs
in Just (map (\z -> z - colspan) as ++ bs, [cell]:revrows)
let addCell tableSection cell (TableData tdata) =
TableData (M.alter (addCell' cell) tableSection tdata)
let toCell tableSection tableData contents = do
case contents of
[Elt (Identifier "grid.cell") _pos fs] -> do
bs <- B.toList <$> (getField "body" fs >>= pWithContents pBlocks)
rowspan <- getField "rowspan" fs <|> pure 1
colspan <- getField "colspan" fs <|> pure 1
align' <- (toAlign <$> getField "align" fs) <|> pure B.AlignDefault
pure $ addCell tableSection
(B.Cell B.nullAttr align' (B.RowSpan rowspan)
(B.ColSpan colspan) bs) tableData
[Elt (Identifier "table.cell") pos fs] ->
toCell tableSection tableData [Elt (Identifier "grid.cell") pos fs]
[Elt (Identifier "table.vline") _pos _fs] -> pure tableData
[Elt (Identifier "table.hline") _pos _fs] -> pure tableData
[Elt (Identifier "grid.vline") _pos _fs] -> pure tableData
[Elt (Identifier "grid.hline") _pos _fs] -> pure tableData
[Elt (Identifier "table.header") _pos fs] ->
getField "children" fs >>=
foldM (toCell THeader) tableData . V.toList
[Elt (Identifier "table.footer") _pos fs] ->
getField "children" fs >>=
foldM (toCell TFooter) tableData . V.toList
_ -> do
bs <- B.toList <$> pWithContents pBlocks contents
pure $ addCell tableSection
(B.Cell B.nullAttr B.AlignDefault (B.RowSpan 1) (B.ColSpan 1) bs)
tableData
tableData <- foldM (toCell TBody) (TableData mempty) children
let getRows tablePart = map (B.Row B.nullAttr . reverse)
. maybe [] (reverse . snd)
. M.lookup tablePart . unTableData
let headRows = getRows THeader tableData
let bodyRows = getRows TBody tableData
let footRows = getRows TFooter tableData
pure $ compactifyTable $ B.tableWith
(fromMaybe "" mbident, [], [])
(B.Caption mempty mempty)
colspecs
(B.TableHead B.nullAttr headRows)
[B.TableBody B.nullAttr 0 [] bodyRows]
(B.TableFoot B.nullAttr footRows)
data TableSection = THeader | TBody | TFooter
deriving (Show, Ord, Eq)
newtype TableData =
TableData { unTableData :: M.Map TableSection ([Int], [[Cell]]) }
deriving (Show)
-- for each table section, we have a pair
-- the first element indicates the number of column spaces left
-- in [currentLine, nextLine, lineAfter, etc.]
-- the second element is a list of rows, in reverse order,
-- each of which is a list of cells, in reverse order