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

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# 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 <[email protected]>
   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.Shared (tshow, blocksToInlines)
import Control.Monad.Except (throwError)
import Control.Monad (MonadPlus (mplus), void, guard, foldM)
import qualified Data.Foldable as F
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe, isJust)
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 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 }
            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 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
      labs <- sLabels <$> getState
      labelTarget <- (do result <- getField "target" fields
                         case result of
                           VLabel t | t `elem` labs -> pure True
                           _ -> pure False)
                  <|> pure False
      if tname == "ref" && not labelTarget
         then 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 handler -> handler pos Nothing (M.mapKeys targetToKey fields)
         else do
          case M.lookup name inlineHandlers of
            Nothing -> do
              ignored ("unknown inline element " <> tname <>
                       " at " <> tshow pos)
              pure mempty
            Just handler -> handler pos Nothing fields

-- Pull block elements out of inline elements, e.g.
-- Elt "smallcaps" [ Elt "heading" [..] ] ->
-- Elt "heading" [ Elt "smallcaps" [..]]. See #11017.
fixNesting :: Content -> Content
fixNesting el@(Elt name pos fields)
  | Just (VContent elts) <- M.lookup "body" fields
  = let elts' = fmap fixNesting elts
        fields' = M.insert "body" (VContent elts') fields
        in if isInline el
              then case getField "body" fields' of
                        Just ([el'@(Elt name' pos' fields'')] :: Seq Content)
                          | isBlock el'
                          , not (isInline el')
                          , "body" `M.member` fields''
                          -> Elt name' pos' $
                               M.insert "body" (VContent
                                                (Seq.singleton
                                                  (Elt name pos fields'')))
                                        fields'
                        _ -> Elt name pos fields'
              else Elt name pos fields'
fixNesting x = x

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
  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 :: M.Map Identifier
     (Maybe SourcePos -> Maybe Text ->
      M.Map Identifier Val -> P PandocPure B.Blocks))

inlineKeys :: Set.Set Identifier
inlineKeys = Set.fromList $ M.keys
  (inlineHandlers :: M.Map Identifier
     (Maybe SourcePos -> Maybe Text ->
      M.Map Identifier Val -> P PandocPure B.Inlines))

blockHandlers :: PandocMonad m =>
                   M.Map Identifier
                   (Maybe SourcePos -> Maybe Text ->
                    M.Map Identifier Val -> P m B.Blocks)
blockHandlers = M.fromList
  [("text", \_ _ fields -> do
      body <- getField "body" fields
      -- sometimes text elements include para breaks
      notFollowedBy $ void $ pWithContents pInlines body
      pWithContents pBlocks body)
  ,("title", \_ _ 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", \_ _ fields -> do
      body <- getField "body" fields
      B.divWith ("", ["box"], []) <$> pWithContents pBlocks body)
  ,("heading", \_ mbident fields -> do
      body <- getField "body" fields
      lev <- getField "level" fields <|> pure 1
      B.headerWith (fromMaybe "" mbident,[],[]) lev
         <$> pWithContents pInlines body)
  ,("quote", \_ _ 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", \_ _ fields -> do
      children <- V.toList <$> getField "children" fields
      B.bulletList <$> mapM (pWithContents pBlocks) children)
  ,("list.item", \_ _ fields -> getField "body" fields >>= pWithContents pBlocks)
  ,("enum", \_ _ 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", \_ _ fields -> getField "body" fields >>= pWithContents pBlocks)
  ,("terms", \_ _ 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", \_ _ fields -> getField "body" fields >>= pWithContents pBlocks)
  ,("raw", \_ 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", \_ _ _ -> pure mempty)
  ,("block", \_ mbident fields ->
      maybe id (\ident -> B.divWith (ident, [], [])) mbident
        <$> (getField "body" fields >>= pWithContents pBlocks))
  ,("place", \_ _ fields -> do
      ignored "parameters of place"
      getField "body" fields >>= pWithContents pBlocks)
  ,("columns", \_ _ fields -> do
      (cnt :: Integer) <- getField "count" fields
      B.divWith ("", ["columns-flow"], [("count", T.pack (show cnt))])
        <$> (getField "body" fields >>= pWithContents pBlocks))
  ,("rect", \_ _ fields ->
      B.divWith ("", ["rect"], []) <$> (getField "body" fields >>= pWithContents pBlocks))
  ,("circle", \_ _ fields ->
      B.divWith ("", ["circle"], []) <$> (getField "body" fields >>= pWithContents pBlocks))
  ,("ellipse", \_ _ fields ->
      B.divWith ("", ["ellipse"], []) <$> (getField "body" fields >>= pWithContents pBlocks))
  ,("polygon", \_ _ fields ->
      B.divWith ("", ["polygon"], []) <$> (getField "body" fields >>= pWithContents pBlocks))
  ,("square", \_ _ fields ->
      B.divWith ("", ["square"], []) <$> (getField "body" fields >>= pWithContents pBlocks))
  ,("align", \_ _ fields -> do
      alignment <- getField "alignment" fields
      B.divWith ("", [], [("align", repr alignment)])
        <$> (getField "body" fields >>= pWithContents pBlocks))
  ,("stack", \_ _ 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", \_ mbident fields -> parseTable mbident fields)
  ,("table", \_ mbident fields -> parseTable mbident fields)
  ,("figure", \_ 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", \_ _ fields ->
      case ( M.lookup "start" fields
              >> M.lookup "end" fields
              >> M.lookup "angle" fields ) of
        Nothing -> pure B.horizontalRule
        _ -> pure mempty)
  ,("numbering", \_ _ 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", \_ _ fields ->
      getField "body" fields >>= pWithContents pBlocks)
  ,("pad", \_ _ fields ->  -- ignore paddingy
      getField "body" fields >>= pWithContents pBlocks)
  ,("pagebreak", \_ _ _ -> pure $ B.divWith ("", ["page-break"], [("wrapper", "1")]) B.horizontalRule)
  ]

inlineHandlers :: PandocMonad m =>
    M.Map Identifier (Maybe SourcePos -> Maybe Text ->
                      M.Map Identifier Val -> P m B.Inlines)
inlineHandlers = M.fromList
  [("ref", \_ _ 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", \_ _ _ -> pure B.linebreak)
  ,("text", \_ _ 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", \_ _ fields -> B.code . T.filter (/= '\r') <$> getField "text" fields)
  ,("footnote", \_ _ fields ->
      B.note <$> (getField "body" fields >>= pWithContents pBlocks))
  ,("cite", \_ _ 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
                                    "year" -> B.SuppressAuthor
                                    _ -> B.NormalCitation,
                B.citationNoteNum = 0,
                B.citationHash = 0
              }
      pure $ B.cite [citation] (B.text $ "[" <> key <> "]"))
  ,("lower", \_ _ fields -> do
      body <- getField "text" fields
      walk (modString T.toLower) <$> pWithContents pInlines body)
  ,("upper", \_ _ fields -> do
      body <- getField "text" fields
      walk (modString T.toUpper) <$> pWithContents pInlines body)
  ,("emph", \_ _ fields -> do
      body <- getField "body" fields
      B.emph <$> pWithContents pInlines body)
  ,("strong", \_ _ fields -> do
      body <- getField "body" fields
      B.strong <$> pWithContents pInlines body)
  ,("sub", \_ _ fields -> do
      body <- getField "body" fields
      B.subscript <$> pWithContents pInlines body)
  ,("super", \_ _ fields -> do
      body <- getField "body" fields
      B.superscript <$> pWithContents pInlines body)
  ,("strike", \_ _ fields -> do
      body <- getField "body" fields
      B.strikeout <$> pWithContents pInlines body)
  ,("smallcaps", \_ _ fields -> do
      body <- getField "body" fields
      B.smallcaps <$> pWithContents pInlines body)
  ,("underline", \_ _ fields -> do
      body <- getField "body" fields
      B.underline <$> pWithContents pInlines body)
  ,("quote", \_ _ fields -> do
      (getField "block" fields <|> pure False) >>= guard . not
      body <- getInlineBody fields >>= pWithContents pInlines
      pure $ B.doubleQuoted $ B.trimInlines body)
  ,("link", \_ _ 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", \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", \_ _ fields -> do
      body <- getField "body" fields
      B.spanWith ("", ["box"], []) <$> pWithContents pInlines body)
  ,("h", \_ _ 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", \_ _ fields -> do
      ignored "parameters of place"
      getField "body" fields >>= pWithContents pInlines)
  ,("align", \_ _ fields -> do
      alignment <- getField "alignment" fields
      B.spanWith ("", [], [("align", repr alignment)])
        <$> (getField "body" fields >>= pWithContents pInlines))
  ,("sys.version", \_ _ _ -> pure $ B.text "typst-hs")
  ,("math.equation", \_ _ fields -> do
      body <- getField "body" fields
      display <- getField "block" fields
      (if display then B.displayMath else B.math) . writeTeX <$> pMathMany body)
  ,("pad", \_ _ fields ->  -- ignore paddingy
      getField "body" fields >>= pWithContents pInlines)
  ,("block", \_ mbident fields ->
      maybe id (\ident -> B.spanWith (ident, [], [])) mbident
        <$> (getField "body" fields >>= pWithContents pInlines))
  ]

getInlineBody :: PandocMonad m => M.Map Identifier Val -> P m (Seq Content)
getInlineBody fields =
  parbreaksToLinebreaks <$> getField "body" fields

parbreaksToLinebreaks :: Seq Content -> Seq Content
parbreaksToLinebreaks =
  fmap go . Seq.dropWhileL isParbreak . Seq.dropWhileR isParbreak
 where
   go (Elt "parbreak" pos _) = Elt "linebreak" pos mempty
   go x = x
   isParbreak (Elt "parbreak" _ _) = True
   isParbreak _ = False

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 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 -> [Text]
findLabels = foldr go []
 where
   go (Txt{}) = id
   go (Lab t) = (t :)
   go (Elt{ eltFields = fs }) = \ts -> foldr go' ts fs
   go' (VContent cs) = (findLabels cs ++)
   go' _ = id

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 $
    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