content: {-# LANGUAGE RankNTypes #-}
  {-# 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 <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.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)
  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
    pure $ B.doc bs
    -- The following alternative code would add metadata from the
    -- fields on the document element. It is commented out because
    -- the typst metadata doesn't print anything by default, in contrast
    -- to pandoc with its usual templates.  Hence, with this code,
    -- converting a typst document might yield a double title, author, etc.
    --
    -- 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 []
    -- pure $
    --   (if title == mempty
    --       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) $ B.doc 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)
    ,("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
  