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

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}

{- |
   Module      : Text.Pandoc.Readers.AsciiDoc
   Copyright   : Copyright (C) 2024 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <[email protected]>
   Stability   : alpha
   Portability : portable

Reads and evaluates a AsciiDoc document as a Pandoc AST.
-}
module Text.Pandoc.Readers.AsciiDoc
  ( readAsciiDoc
  )
where

import Text.Pandoc.Class
import Text.Pandoc.Options
import Text.Pandoc.Definition
import Text.Pandoc.Walk
import Text.Pandoc.Shared (addPandocAttributes, blocksToInlines, safeRead,
                           tshow)
import qualified Text.Pandoc.UTF8 as UTF8
import qualified AsciiDoc as A
import Text.Pandoc.Error
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Readers.HTML (readHtml)
import Control.Monad.Except (throwError)
import Control.Monad (mplus)
import Text.Pandoc.Parsing (newPos, sourceName)
import Text.Pandoc.Logging
import Text.Pandoc.Sources
import Control.Monad.State
import Data.List (intersperse, foldl')
import Data.Char (chr)
import qualified Data.Text as T
import qualified Data.Map as M
import Data.Maybe (fromMaybe)

-- import Debug.Trace

-- | Read AsciiDoc from an input string and return a Pandoc document.
readAsciiDoc :: (PandocMonad m, ToSources a) => ReaderOptions -> a -> m Pandoc
readAsciiDoc _opts inp = do
  let Sources sources = toSources inp
  (mconcat <$> mapM
   (\(sourcepos, t) ->
     A.parseDocument getIncludeFile raiseError (sourceName sourcepos) t)
    sources)
   >>= resolveFootnotes
   >>= resolveStem
   >>= resolveIcons
   >>= toPandoc
 where
  getIncludeFile fp = UTF8.toText <$> readFileStrict fp
  raiseError pos msg = throwError $ PandocParseError $ T.pack
                          $ msg <> " at position " <> show pos

toPandoc :: PandocMonad m => A.Document -> m Pandoc
toPandoc doc =
  Pandoc <$> doMeta (A.docMeta doc)
         <*> (B.toList <$> doBlocks (A.docBlocks doc))

resolveFootnotes :: Monad m => A.Document -> m A.Document
resolveFootnotes doc = do
  evalStateT (A.mapInlines go doc) (mempty :: M.Map T.Text [A.Inline])
 where
   go (A.Inline attr (A.Footnote (Just (A.FootnoteId fnid)) ils)) = do
     fnmap <- get
     case M.lookup fnid fnmap of
       Just ils' ->
         pure $ A.Inline attr (A.Footnote (Just (A.FootnoteId fnid)) ils')
       Nothing -> do
         put $ M.insert fnid ils fnmap
         pure $ A.Inline attr (A.Footnote (Just (A.FootnoteId fnid)) ils)
   go x = pure x

resolveStem :: Monad m => A.Document -> m A.Document
resolveStem doc = do
  let defaultType = case M.lookup "stem" (A.docAttributes (A.docMeta doc)) of
                      Just "asciimath" -> A.AsciiMath
                      _ -> A.LaTeXMath
  let doInlineStem (A.Inline attr (A.Math Nothing t)) =
        pure $ A.Inline attr (A.Math (Just defaultType) t)
      doInlineStem x = pure x
  let doBlockStem (A.Block attr mbtit (A.MathBlock Nothing t)) =
        pure $ A.Block attr mbtit (A.MathBlock (Just defaultType) t)
      doBlockStem x = A.mapInlines doInlineStem x
  A.mapBlocks doBlockStem doc

-- resolve icons as either characters in an icon font or images
resolveIcons :: Monad m => A.Document -> m A.Document
resolveIcons doc = A.mapInlines fromIcon doc
 where
   docattrs = A.docAttributes (A.docMeta doc)
   iconFont = case M.lookup "icons" docattrs of
                Just "font" -> True
                _ -> False
   iconsdir = fromMaybe "./images/icons" $ M.lookup "iconsdir" docattrs
   icontype = fromMaybe "png" $ M.lookup "icontype" docattrs
   addClasses cls (A.Attr ps kvs) =
     A.Attr ps $
      case M.lookup "role" kvs of
       Just r -> M.insert "role" (T.unwords (r : cls)) kvs
       Nothing -> M.insert "role" (T.unwords cls) kvs
   fromIcon (A.Inline attr (A.Icon name)) =
     if iconFont
        then pure $
              A.Inline (addClasses ["fa", "fa-" <> name] attr) (A.Span [])
        else pure $ -- default is to use an image
              A.Inline (addClasses ["icon"] attr)
                 (A.InlineImage
                   (A.Target
                      (iconsdir <> "/" <> name <> "." <> icontype))
                      Nothing Nothing Nothing)
   fromIcon x = pure x

addAttribution :: Maybe A.Attribution -> B.Blocks -> B.Blocks
addAttribution Nothing bs = bs
addAttribution (Just (A.Attribution t)) bs = B.fromList $
  case B.toList bs of
    [B.Div attr bls] -> [B.Div attr (bls ++ [attrBlock])]
    [B.BlockQuote bls] -> [B.BlockQuote (bls ++ [attrBlock])]
    xs -> xs ++ [attrBlock]
 where
   attrBlock = Para (B.toList $ B.text $ "\x2014 " <> t)

doMeta :: PandocMonad m => A.Meta -> m B.Meta
doMeta meta = do
  tit' <- doInlines (A.docTitle meta)
  pure $
    (if tit' == mempty
        then id
        else B.setMeta "title" tit') .
    (case A.docAuthors meta of
       [] -> id
       as -> B.setMeta "author" (map fromAuthor as)) .
    (case A.docRevision meta of
       Nothing -> id
       Just (A.Revision vers mbdate mbremark) ->
         B.setMeta "version" vers .
         maybe id (B.setMeta "date") mbdate .
         maybe id (B.setMeta "remark") mbremark) .
    flip (foldl' (\m (k,v) ->
                    -- leave out flags that are set just for processing
                    if k == "sectids" || k == "stem"
                       then m
                       else if T.null v
                               then B.setMeta k True m
                               else B.setMeta k v m))
      (M.toList (A.docAttributes meta))
    $ mempty

fromAuthor :: A.Author -> B.Inlines
fromAuthor au = B.text (A.authorName au) <>
  maybe mempty (\email ->
    " (" <> B.link ("mailto:" <> email) "" (B.str email) <> ")")
    (A.authorEmail au)

doBlocks :: PandocMonad m => [A.Block] -> m B.Blocks
doBlocks = fmap mconcat . mapM doBlock

addBlockAttr :: A.Attr -> B.Blocks -> B.Blocks
addBlockAttr (A.Attr _ kvs') bs =
  case B.toList bs of
    x@(B.OrderedList{}) : xs -> -- "start" is handled in list attribs
      addPandocAttributes (M.toList $ M.delete "start" kvs)
             (B.singleton x) <> B.fromList xs
    x:xs -> addPandocAttributes (M.toList kvs) (B.singleton x)
                <> B.fromList xs
    [] -> mempty
 where
  kvs = M.mapKeys (\k -> if k == "role" then "class" else k) kvs'

addBlockTitle :: B.Inlines -> B.Blocks -> B.Blocks
addBlockTitle tit' bs =
  let tit = B.toList tit'
  in case B.toList bs of
    [B.Table attr _ colspecs thead tbody tfoot] ->
      B.singleton $ B.Table attr (B.Caption Nothing [B.Plain tit])
                     colspecs thead tbody tfoot
    [B.Figure attr _ bs'] ->
      B.singleton $ B.Figure attr (B.Caption Nothing [B.Plain tit]) bs'
    [B.Div attr (B.Div ("",["title"],[]) [Para _] : bs')] ->
      -- replace existing title, which might be e.g. "Note"
      B.singleton $ B.Div attr (B.Div ("",["title"],[]) [B.Para tit] : bs')
    [B.Div attr bs'] -> -- put title Div inside
      B.singleton $ B.Div attr (B.Div ("",["title"],[]) [B.Para tit] : bs')
    _ -> B.divWith B.nullAttr (B.divWith ("",["title"],[]) (B.para tit') <> bs) 

doBlock :: PandocMonad m => A.Block -> m B.Blocks
doBlock (A.Block attr@(A.Attr ps kvs) mbtitle bt) = do
  mbtitle' <- case mbtitle of
                Nothing -> pure Nothing
                Just (A.BlockTitle ils) -> Just <$> doInlines ils
  addBlockAttr attr . maybe id addBlockTitle mbtitle' <$>
   case bt of
    A.Section (A.Level lev) ils bs -> do
      ils' <- doInlines ils
      bs' <- doBlocks bs
      pure $ (B.header lev ils') <> bs'
    A.DiscreteHeading (A.Level lev) ils ->
      B.header lev <$> doInlines ils
    A.Paragraph ils -> B.para <$> doInlines ils
    A.LiteralBlock t -> pure $ B.codeBlock t
    A.Listing mblang lns -> do
      let fromCallout (A.Callout i)
            | i <= 20 = T.pack [' ', chr (0x2460 + i - 1)]
            | otherwise = "<" <> tshow i <> ">"
      let fromSourceLine (A.SourceLine t callouts) =
            t <> mconcat (map fromCallout callouts)
      let code = T.intercalate "\n" $ map fromSourceLine lns
      let classes = case mblang of
                      Nothing -> []
                      Just (A.Language l) -> [l]
      pure $ B.codeBlockWith ("", classes, []) code
    A.IncludeListing _ _ Nothing -> pure mempty
    A.IncludeListing mblang _fp (Just lns) ->
      doBlock (A.Block mempty mbtitle (A.Listing mblang lns))
    A.ExampleBlock bs -> B.divWith ("",["example"],[]) <$> doBlocks bs
    A.Sidebar bs -> B.divWith ("",["sidebar"],[]) <$> doBlocks bs
    A.OpenBlock bs -> B.divWith ("",[],[]) <$> doBlocks bs
    A.QuoteBlock mbattrib bs ->
      addAttribution mbattrib . B.blockQuote <$> doBlocks bs
    A.Verse mbattrib bs ->
      addAttribution mbattrib . B.blockQuote <$> doBlocks bs
    -- TODO when texmath's asciimath parser works, convert:
    A.MathBlock (Just A.AsciiMath) t -> pure $ B.para $ B.displayMath t
    A.MathBlock (Just A.LaTeXMath) t -> pure $ B.para $ B.displayMath t
    A.MathBlock Nothing _ ->
      throwError $ PandocParseError "Encountered math type Nothing"
    A.List (A.BulletList _) items ->
      B.bulletList <$> mapM doItem items
    A.List A.CheckList items ->
      B.bulletList <$> mapM doItem items
    A.List (A.OrderedList _ mbstart) items -> do
      let start = fromMaybe (1 :: Int)
                    (mbstart `mplus` (M.lookup "start" kvs >>= safeRead))
      let getStyle xs = case xs of
                  "arabic":_ -> Decimal
                  "decimal":_ -> Decimal
                  "loweralpha":_ -> LowerAlpha
                  "upperalpha":_ -> UpperAlpha
                  "lowerroman":_ -> LowerRoman
                  "upperroman":_ -> UpperRoman
                  _:rest -> getStyle rest
                  [] -> DefaultStyle
      let sty = getStyle ps
      let delim = DefaultDelim
      B.orderedListWith (start, sty, delim) <$> mapM doItem items
    A.List A.CalloutList items ->
      B.divWith ("",["callout-list"],[]) . B.orderedList <$> mapM doItem items
    A.DefinitionList items
      | "ordered" `elem` ps ->
          B.orderedList <$>
             mapM (fmap (B.definitionList . (:[])) . doDefListItem) items
      | otherwise -> B.definitionList <$> mapM doDefListItem items
    A.Table specs mbHeader rows mbFooter -> do
      let toAlign A.AlignLeft = B.AlignLeft
          toAlign A.AlignCenter = B.AlignCenter
          toAlign A.AlignRight = B.AlignRight
      let fromCell (A.TableCell bs mbHorizAlign _mbVertAlign colspan rowspan) =
            B.Cell B.nullAttr (maybe B.AlignDefault toAlign mbHorizAlign)
                        (B.RowSpan rowspan) (B.ColSpan colspan) . B.toList
                   <$> doBlocks bs
      let fromRow (A.TableRow cs) = B.Row B.nullAttr <$> mapM fromCell cs
      tbody <- B.TableBody B.nullAttr (B.RowHeadColumns 0) [] <$> mapM fromRow rows
      thead <- B.TableHead B.nullAttr <$> maybe (pure []) (mapM fromRow) mbHeader
      tfoot <- B.TableFoot B.nullAttr <$> maybe (pure []) (mapM fromRow) mbFooter
      let totalWidth = sum $ map (fromMaybe 1 . A.colWidth) specs
      let toColSpec spec = (maybe B.AlignDefault toAlign (A.colHorizAlign spec),
                             maybe B.ColWidthDefault
                               (B.ColWidth . (\x ->
                                   fromIntegral x / fromIntegral totalWidth))
                               (A.colWidth spec))
      let colspecs = map toColSpec specs
      pure $ B.table (B.Caption Nothing mempty) -- added by addBlockTitle
                colspecs thead [tbody] tfoot
    A.BlockImage target mbalt mbw mbh -> do
      img' <- doInline (A.Inline mempty (A.InlineImage target mbalt mbw mbh))
      -- TODO have a global function that adds the title to caption here:
      pure $ B.figure (Caption Nothing mempty) -- added by addBlockTitle
                      (B.plain img')
    -- TODO alt text?
    A.BlockAudio (A.Target t) ->
      pure $ B.plain $ B.image t "" (B.str t)
    -- TODO alt text?
    A.BlockVideo (A.Target t) ->
      pure $ B.plain $ B.image t "" (B.str t)
    A.TOC -> pure $ B.divWith ("toc",[],[]) mempty
    A.Admonition admonitionType bs -> do
      let admon = T.pack $ show admonitionType
      bs' <- doBlocks bs
      pure $ B.divWith ("",[T.toLower admon],[])
           $ B.divWith ("",["title"],[]) (B.para (B.str admon)) <> bs'
    A.PageBreak ->
      pure $ B.divWith ("", ["page-break"], [("wrapper", "1")]) B.horizontalRule
    A.ThematicBreak -> pure $ B.horizontalRule
    A.Include fp (Just bs) ->
      B.divWith ("",["included"],[("path",T.pack fp)]) <$> doBlocks bs
    A.Include fp Nothing -> do
      report $ CouldNotLoadIncludeFile (T.pack fp) (newPos "" 0 0)
      pure mempty
    A.PassthroughBlock t ->
         case runPure (readHtml def{
                               readerExtensions = extensionsFromList [Ext_raw_html]
                               } t) of
        Left _ -> pure $ B.rawBlock "html" t
        Right (Pandoc _ bs) -> pure $ B.fromList bs

doItem :: PandocMonad m => A.ListItem -> m B.Blocks
doItem (A.ListItem Nothing bs) = doBlocks bs
doItem (A.ListItem (Just checkstate) bs) = do
  bs' <- doBlocks bs
  let check = case checkstate of
                A.Checked -> Str "\9746"
                A.Unchecked -> Str "\9744"
  pure $ B.fromList
       $ case B.toList bs' of
           (B.Para ils : rest) -> B.Para (check : B.Space : ils) : rest
           (B.Plain ils : rest) -> B.Plain (check : B.Space : ils) : rest
           rest -> B.Para [check] : rest

doDefListItem :: PandocMonad m
              => ([A.Inline], [A.Block]) -> m (B.Inlines , [B.Blocks])
doDefListItem (lab, bs) = do
  lab' <- doInlines lab
  bs' <- doBlocks bs
  pure (lab', [bs'])

doInlines :: PandocMonad m => [A.Inline] -> m B.Inlines
doInlines = fmap mconcat . mapM doInline

doInline :: PandocMonad m => A.Inline -> m B.Inlines
doInline (A.Inline (A.Attr _ps kvs') it) = do
  let kvs = M.mapKeys (\k -> if k == "role" then "class" else k) kvs'
  addPandocAttributes (M.toList kvs) <$>
   case it of
    A.Str t -> pure $ B.text t
    A.HardBreak -> pure B.linebreak
    A.Bold ils -> B.strong <$> doInlines ils
    A.Italic ils -> B.emph <$> doInlines ils
    A.Monospace ils -> walk monospaceStr <$> doInlines ils
    A.Superscript ils -> B.superscript <$> doInlines ils
    A.Subscript ils -> B.subscript <$> doInlines ils
    A.Highlight ils -> B.spanWith ("",["mark"],[]) <$> doInlines ils
    A.Strikethrough ils -> B.strikeout <$> doInlines ils
    A.DoubleQuoted ils -> B.doubleQuoted <$> doInlines ils
    A.SingleQuoted ils -> B.singleQuoted <$> doInlines ils
    -- TODO when texmath's asciimath parser works, convert:
    A.Math (Just A.AsciiMath) t -> pure $ B.math t
    A.Math (Just A.LaTeXMath) t -> pure $ B.math t
    A.Math Nothing _ ->
      throwError $ PandocParseError "Encountered math type Nothing"
    A.Icon t -> pure $ B.spanWith ("",["icon"],[("name",t)])
                         (B.str ("[" <> t <> "]"))
    A.Button t -> pure $ B.spanWith ("",["button"],[])
                         (B.strong $ B.str ("[" <> t <> "]"))
    A.Kbd ts -> pure $ mconcat $ intersperse (B.str "+") $
         map (B.spanWith ("",["kbd"],[]) . B.strong . B.str) ts
    A.Menu ts -> pure $ B.spanWith ("",["menu"],[]) $
        B.strong $ B.text $ T.intercalate " › " ts
    -- TODO do we need linktype?
    A.Link _linkType (A.Target t) ils -> B.link t "" <$> doInlines ils
    A.InlineImage (A.Target url) mbalt mbwidth mbheight -> do
      let alt = case mbalt of
                  Just (A.AltText t) -> B.text t
                  Nothing -> mempty
          width = case mbwidth of
                  Just (A.Width n) -> [("width", T.pack $ show n <> "px")]
                  Nothing -> []
          height = case mbheight of
                  Just (A.Height n) -> [("height", T.pack $ show n <> "px")]
                  Nothing -> []
      pure $ B.imageWith ("",[], width ++ height) url "" alt
    A.Footnote _ ils -> B.note . B.para <$> doInlines ils
    A.InlineAnchor t _ -> pure $ B.spanWith (t, [], []) mempty
    A.BibliographyAnchor t _ -> pure $ B.spanWith (t, [], []) mempty
    A.CrossReference t Nothing ->
      pure $ B.linkWith ("",["cross-reference"],[]) ("#" <> t) "" (B.str t)
    A.CrossReference t (Just ils) -> do
      B.linkWith ("",["cross-reference"],[]) ("#" <> t) "" <$> doInlines ils
    A.AttributeReference (A.AttributeName t) -> -- if this is here, it's unresolved
      pure $ B.str ("{" <> t <> "}")
    A.Span ils -> B.spanWith B.nullAttr <$> doInlines ils
    A.IndexEntry (A.TermInText t) ->
      pure $ B.spanWith ("",["index"],[("term",t)]) (B.text t)
    A.IndexEntry (A.TermConcealed ts) ->
      pure $ B.spanWith ("",["index"],[("term",T.intercalate "," ts)]) mempty
    -- Passthrough is hard to get right, because pandoc's RawInline needs
    -- a format specifier. Often in asciidoc passthrough is used as a form
    -- of escaping, so the best approach seems to be treating it as HTML
    -- and parsing it:
    A.Passthrough t -> do
      case runPure (readHtml def{
                               readerExtensions = extensionsFromList [Ext_raw_html]
                               } t) of
        Left _ -> pure $ B.rawInline "html" t
        Right (Pandoc _ bs) -> pure $ B.fromList . blocksToInlines $ bs

monospaceStr :: Inline -> Inline
monospaceStr (Str t) = Code B.nullAttr t
monospaceStr x = x