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

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

{- |
   Module      : Text.Pandoc.Readers.Djot
   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 Djot document as a Pandoc AST.
-}
module Text.Pandoc.Readers.Djot
  ( readDjot
  )
where

import Text.Pandoc.Class
import Text.Pandoc.Sources
import Text.Parsec.Pos (newPos)
import Text.Pandoc.Options
import Text.Pandoc.Definition
import Text.Pandoc.Shared (addPandocAttributes, tshow)
import qualified Text.Pandoc.UTF8 as UTF8
import Djot (ParseOptions(..), SourcePosOption(..), parseDoc, Pos(..))
import qualified Djot.AST as D
import Text.Pandoc.Error (PandocError(..))
import Control.Monad.Except (throwError)
import qualified Data.Text as T
import Text.Pandoc.Builder
import Text.Pandoc.Logging
import Text.Pandoc.Emoji (emojiToInline)
import Control.Monad.Reader
import qualified Data.Foldable as F
import Data.List (foldl')
import Data.ByteString (ByteString)
-- import Debug.Trace

-- | Read Djot from an input string and return a Pandoc document.
readDjot :: (PandocMonad m, ToSources a) => ReaderOptions -> a -> m Pandoc
readDjot opts inp = do
  let sources = toSources inp
  case parseDoc ParseOptions{ sourcePositions =
                              if isEnabled Ext_sourcepos opts
                                 then AllSourcePos
                                 else NoSourcePos }
          (UTF8.fromText $ sourcesToText sources) of
    Left e -> throwError $ PandocParseError $ T.pack $ show e
    Right d ->
      runReaderT (doc <$> convertBlocks (D.docBlocks d))
        Env{ references = D.docReferences d <> D.docAutoReferences d
           , footnotes = D.docFootnotes d
           }

data Env =
  Env{ references :: D.ReferenceMap
     , footnotes :: D.NoteMap
     }
  deriving (Show, Ord, Eq)

convertBlocks :: PandocMonad m => D.Blocks -> ReaderT Env m Blocks
convertBlocks =  fmap mconcat . mapM convertBlock . F.toList . D.unMany

convertBlock :: PandocMonad m => D.Node D.Block -> ReaderT Env m Blocks
convertBlock (D.Node pos attr bl) =  addAttrToBlock pos attr <$>
  case bl of
    D.Para ils -> para <$> convertInlines ils
    D.Section bls -> divWith ("",["section"],[]) <$> convertBlocks bls
    D.Heading lev ils -> header lev <$> convertInlines ils
    D.BlockQuote bls -> blockQuote <$> convertBlocks bls
    D.CodeBlock lang bs -> pure $
      codeBlockWith ("", [UTF8.toText lang], []) $ UTF8.toText bs
    D.Div bls -> divWith nullAttr <$> convertBlocks bls
    D.OrderedList olattr listSpacing items ->
      orderedListWith olattr' .
        (case listSpacing of
           D.Tight -> map toTight
           D.Loose -> id) <$> mapM convertBlocks items
     where
       olattr' = ( D.orderedListStart olattr
                 , case D.orderedListStyle olattr of
                     D.Decimal -> Decimal
                     D.LetterUpper -> UpperAlpha
                     D.LetterLower -> LowerAlpha
                     D.RomanUpper -> UpperRoman
                     D.RomanLower -> LowerRoman
                 , case D.orderedListDelim olattr of
                     D.RightPeriod -> Period
                     D.RightParen -> OneParen
                     D.LeftRightParen -> TwoParens
                 )
    D.BulletList listSpacing items ->
        bulletList .
        (case listSpacing of
           D.Tight -> map toTight
           D.Loose -> id) <$> mapM convertBlocks items
    D.TaskList listSpacing items ->
        bulletList .
        (case listSpacing of
           D.Tight -> map toTight
           D.Loose -> id) <$> mapM toTaskListItem items
    D.DefinitionList listSpacing items ->
      definitionList .
        (case listSpacing of
           D.Tight -> map (\(t,d) -> (t, map toTight d))
           D.Loose -> id) <$> mapM toDlItem items
     where
       toDlItem (ils,bls) = (,) <$> convertInlines ils
                                <*> ((:[]) <$> convertBlocks bls)
    D.ThematicBreak -> pure horizontalRule
    D.Table mbCaption rows -> do
      capt <- case mbCaption of
                Just (D.Caption bls') ->
                  Caption Nothing . toList <$> convertBlocks bls'
                Nothing -> pure $ Caption Nothing mempty
      let toAlign D.AlignLeft = AlignLeft
          toAlign D.AlignRight = AlignRight
          toAlign D.AlignCenter = AlignCenter
          toAlign D.AlignDefault = AlignDefault
      let toColSpec (D.Cell _ align _) = (toAlign align, ColWidthDefault)
      let colspecs = case rows of
                      [] -> []
                      (cells:_) -> map toColSpec cells
      let (headrow, rest) =
            case rows of
              (r@(D.Cell D.HeadCell _ _ : _) : rs) -> (r, rs)
              _ -> ([],rows)
      let getBody bods row =
            case row of
              (D.Cell D.HeadCell _ _ : _) ->
                   case bods of
                     [] -> [([row],[])]
                     ([],_):_ -> (([row],[]):bods)
                     (hs,bs):rs -> (hs,row:bs):rs
              _ -> case bods of
                     (hs,bs):rs -> (hs,row:bs):rs
                     [] -> [([],[row])]
      let reverseSnd (as,bs) = (as,reverse bs)
      let bodies = reverse $ map reverseSnd $ foldl' getBody [] rest
      let toCell (D.Cell _ al ils) =
            Cell nullAttr (toAlign al) (RowSpan 1) (ColSpan 1)
                   . (\is -> [Para $ toList is]) <$> convertInlines ils
      let toRow = fmap (Row nullAttr) . mapM toCell
      thead <- TableHead mempty <$> mapM toRow [headrow]
      let toTableBody (hs, rs) =
            TableBody mempty (RowHeadColumns 0) <$>
              mapM toRow hs <*> mapM toRow rs
      tbodies <- mapM toTableBody bodies
      let tfoot = TableFoot mempty []
      pure $ singleton $ Table mempty capt colspecs thead tbodies tfoot
    D.RawBlock (D.Format fmt) bs -> pure $
      rawBlock (UTF8.toText fmt) (UTF8.toText bs)

addAttrToBlock :: Pos -> D.Attr -> Blocks -> Blocks
addAttrToBlock pos (D.Attr as) =
  addPandocAttributes $
    case pos of
        NoPos -> textkvs
        Pos sl sc el ec ->
          ("data-pos", tshow sl <> ":" <> tshow sc <>
                 "-" <> tshow el <> ":" <> tshow ec) : textkvs
     where
       textkvs = (map (\(k,v) -> (UTF8.toText k, UTF8.toText v))
                    (filter (not . internalAttribute) as))

addAttrToInline :: Pos -> D.Attr -> Inlines -> Inlines
addAttrToInline pos (D.Attr as) =
  addPandocAttributes $
    case pos of
        NoPos -> textkvs
        Pos sl sc el ec ->
          ("data-pos", tshow sl <> ":" <> tshow sc <>
                 "-" <> tshow el <> ":" <> tshow ec) : textkvs
     where
       textkvs = (map (\(k,v) -> (UTF8.toText k, UTF8.toText v))
                    (filter (not . internalAttribute) as))

convertInlines :: PandocMonad m => D.Inlines -> ReaderT Env m Inlines
convertInlines = fmap mconcat . mapM convertInline . F.toList . D.unMany

convertInline :: PandocMonad m => D.Node D.Inline -> ReaderT Env m Inlines
convertInline (D.Node pos attr il) = addAttrToInline pos attr <$>
  case il of
    D.Str bs -> pure $ text (UTF8.toText bs)
    D.Emph ils -> emph <$> convertInlines ils
    D.Strong ils -> strong <$> convertInlines ils
    D.Highlight ils -> spanWith ("",["mark"],[]) <$> convertInlines ils
    D.Insert ils -> spanWith ("",["inserted"],[]) <$> convertInlines ils
    D.Delete ils -> spanWith ("",["deleted"],[]) <$> convertInlines ils
    D.Subscript ils -> subscript <$> convertInlines ils
    D.Superscript ils -> superscript <$> convertInlines ils
    D.Span ils -> spanWith nullAttr <$> convertInlines ils
    D.Quoted D.DoubleQuotes ils -> doubleQuoted <$> convertInlines ils
    D.Quoted D.SingleQuotes ils -> singleQuoted <$> convertInlines ils
    D.Verbatim bs -> pure $ code (UTF8.toText bs)
    D.Symbol bs -> pure $
      let s = UTF8.toText bs
       in maybe (spanWith ("",["symbol"],[]) (str s)) singleton $ emojiToInline s
    D.Math sty bs -> pure $
      (case sty of
        D.DisplayMath -> displayMath
        D.InlineMath -> math) (UTF8.toText bs)
    D.Link ils target ->
      case target of
        D.Direct url -> link (UTF8.toText url) "" <$> convertInlines ils
        D.Reference label -> do
          refs <- asks references
          case D.lookupReference label refs of
            Just (url, lattr) ->
              addAttrToInline pos lattr .
                link (UTF8.toText url) "" <$> convertInlines ils
            Nothing -> do
              report $ ReferenceNotFound (UTF8.toText label) (newPos "" 0 0)
              link "" "" <$> convertInlines ils
    D.Image ils target ->
      case target of
        D.Direct url -> image (UTF8.toText url) "" <$> convertInlines ils
        D.Reference label -> do
          refs <- asks references
          case D.lookupReference label refs of
            Just (url, lattr) ->
              addAttrToInline pos lattr .
                image (UTF8.toText url) "" <$> convertInlines ils
            Nothing -> do
              report $ ReferenceNotFound (UTF8.toText label) (newPos "" 0 0)
              image "" "" <$> convertInlines ils
    D.FootnoteReference bs -> do
      notes <- asks footnotes
      case D.lookupNote bs notes of
        Just bls -> note <$> convertBlocks bls
        Nothing -> do
          -- TODO consider new warning for this?
          report $ IgnoredElement ("Undefined footnote reference " <> tshow bs)
          pure mempty
    D.UrlLink bs -> do
      let url = UTF8.toText bs
      pure $ linkWith ("",["uri"],[]) url "" (str url)
    D.EmailLink bs -> do
      let email = UTF8.toText bs
      pure $ linkWith ("",["email"],[]) ("mailto:" <> email) "" (str email)
    D.RawInline (D.Format fbs) bs -> pure $
      rawInline (UTF8.toText fbs) (UTF8.toText bs)
    D.NonBreakingSpace -> pure $ str "\160"
    D.SoftBreak -> pure softbreak
    D.HardBreak -> pure linebreak

internalAttribute :: (ByteString, ByteString) -> Bool
internalAttribute ("_implicit",_) = True
internalAttribute ("_autogen",_) = True
internalAttribute _ = False

toTight :: Blocks -> Blocks
toTight (Many bls) = Many $ paraToPlain <$> bls
 where
   paraToPlain (Para ils) = Plain ils
   paraToPlain x = x

toTaskListItem :: PandocMonad m
               => (D.TaskStatus, D.Blocks) -> ReaderT Env m Blocks
toTaskListItem (status, bls) = do
  bls' <- convertBlocks bls
  case toList bls' of
    (Para ils : rest) -> pure $
      fromList $ Para (Str taskmarker : Space : ils) : rest
    _ -> pure $ para (str taskmarker) <> bls'
 where
   taskmarker
     | status == D.Complete = "[X]"
     | otherwise = "[ ]"