Inlines.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE BinaryLiterals #-}
module Djot.Inlines
  ( parseInlines
  , parseTableCells
  )
where

import Data.Char (isAscii, isLetter, isAlphaNum, isSymbol, isPunctuation)
import Control.Monad (guard, when, mzero)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as Set
import Djot.Parse
import Djot.Options (ParseOptions(..), SourcePosOption(..))
import Djot.Attributes (pAttributes)
import Djot.AST
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import Data.ByteString (ByteString)
import Data.Foldable as F
import Control.Applicative
import Data.Maybe (fromMaybe)

-- import Debug.Trace

{-# INLINE isSpecial #-}
isSpecial :: Char -> Bool
isSpecial c = c == '[' || c == ']' || c == '<' || c == '>' ||
              c == '$' || c == '!' || c == '{' || c == '}' || c == ':' ||
              c == '=' || c == '+' || c == '-' || c == '^' || c == '~' ||
              c == '*' || c == '_' || c == '\''|| c == '"' || c == '.' ||
              c == '|' || c == '`' || c == '\\'|| c == '\n' || c == '\r'

parseInlines :: ParseOptions -> Seq Chunk -> Either String Inlines
parseInlines opts chunks = do
  case parse (pInlines <* eof) ParserState{ mode = NormalMode
                                          , activeDelims = mempty
                                          , options = opts }
       (toList (stripEndChunks chunks)) of
    Just ils -> Right ils
    Nothing -> Left $ "parseInlines failed on input: "
                     <> show (foldMap chunkBytes chunks)

parseTableCells :: ParseOptions -> Chunk -> Either String [Inlines]
parseTableCells opts chunk = do
  case parse (asciiChar '|'
                 *> some (removeFinalWs <$> pInlines <* asciiChar '|')
                 <* skipMany ws
                 <* eof)
        ParserState{ mode = TableCellMode
                   , activeDelims = mempty
                   , options = opts }
       [chunk] of
    Just cells -> Right cells
    Nothing -> Left $ "parseTableCells failed on input: " <> show chunk

removeFinalWs :: Inlines -> Inlines
removeFinalWs (Many ils) = Many $
  case Seq.viewr ils of
    rest Seq.:> Node pos attr (Str bs)
      | B8.takeEnd 1 bs == " "
        -> case B8.dropWhileEnd (== ' ') bs of
             "" -> rest
             bs' -> rest Seq.|> Node pos attr (Str bs')
    _ -> ils

data InlineParseMode =
  NormalMode | TableCellMode
  deriving (Show, Ord, Eq)

data ParserState =
  ParserState
  { mode :: InlineParseMode
  , activeDelims :: Set Delim
  , options :: ParseOptions }
  deriving (Show)

data Delim = Delim Bool Char
  deriving (Show, Ord, Eq)

type P = Parser ParserState

pInlines :: P Inlines
pInlines = skipMany ws *> (mconcat <$> many pInline)

pInline :: P Inlines
pInline = do
  sline <- sourceLine
  scol <- sourceColumn
  res <- pInline'
  opts <- options <$> getState
  (case sourcePositions opts of
     AllSourcePos -> do
       eline <- sourceLine
       ecol <- sourceColumn
       pure $ addPos (Pos sline scol eline (ecol - 1)) <$> res
     _ -> pure res) >>= pOptionalAttributes

pOptionalAttributes :: Inlines -> P Inlines
pOptionalAttributes (Many ils) = pAddAttributes (Many ils) <|> pure (Many ils)

pAddAttributes :: Inlines -> P Inlines
pAddAttributes (Many ils) = do
  attr <- mconcat <$> some pAttributes
  pure $
    case attr of
      Attr [] -> Many ils
      _ -> case Seq.viewr ils of
             Seq.EmptyR -> mempty
             ils' Seq.:> Node pos attr' (Str bs)
               | B8.any isWs bs ->
               -- attach attribute to last word
               let (front, lastword) = B8.breakEnd isWs bs
               in if B.null lastword
                     then Many ils  -- ignore attr after whitespace
                     else
                       let (pos1, pos2) =
                               case pos of
                                 NoPos -> (NoPos, NoPos)
                                 Pos sl sc el ec ->
                                   let frontlen = B8.length
                                        (B8.filter (\c -> c < '\128' || c >= '\192') front)
                                   in (Pos sl sc sl (sc + frontlen),
                                       Pos sl (sc + frontlen + 1) el ec)
                       in Many (ils' Seq.|>
                                     Node pos1 attr' (Str front) Seq.|>
                                     Node pos2 attr (Str lastword))
             ils' Seq.:> Node pos attr' il ->
               Many (ils' Seq.|> Node pos (attr' <> attr) il)

pInline' :: P Inlines
pInline' = do
  (do c <- lookahead (satisfyByte isSpecial)
      fails pCloser
      (case c of
          '\\' -> pEscaped
          '[' -> pFootnoteReference
             <|> pLinkOrSpan
          '<' -> pAutolink
          '!' -> pImage
          '_' -> pEmph
          '*' -> pStrong
          '^' -> pSuperscript
          '~' -> pSubscript
          '{' -> pEmph
             <|> pStrong
             <|> pHighlight
             <|> pInsert
             <|> pDelete
             <|> pSuperscript
             <|> pSubscript
             <|> pDoubleQuote
             <|> pSingleQuote
             <|> (mempty <$ pAttributes)
          '`' -> pVerbatim
          ':' -> pSymbol
          '$' -> pMath
          '"' -> pDoubleQuote
          '\'' -> pSingleQuote
          '-' -> pHyphens
          '.' -> pEllipses
          '\n' -> pSoftBreak
          _ -> mzero)
        <|> pSpecial
       ) <|> pWords

pSpecial :: P Inlines
pSpecial = do
  st <- getState
  c <- satisfyByte (case mode st of
                       TableCellMode -> \d -> isSpecial d && d /= '|'
                       _ -> isSpecial)
  if c == '\r'
     then pure mempty
     else pure $ str $ B8.singleton c

pWords :: P Inlines
pWords = str <$> byteStringOf (skipSome (skipSatisfyByte (not . isSpecial)))

pEscaped :: P Inlines
pEscaped = do
  asciiChar '\\'
  c <- satisfyByte (\d ->
          isAscii d &&
            (isSymbol d || isPunctuation d || d == ' ' || d == '\t'))
         <|> ('\n' <$ endline)
         <|> pure '\\'
  case c of
    '\n' -> hardBreak <$ skipMany spaceOrTab
    _ | c == ' ' || c == '\t' -> pHardBreak
                             <|> if c == ' '
                                    then pure nonBreakingSpace
                                    else pure $ str "\\\t"
    _ -> pure $ str $ B8.singleton c

pHardBreak :: P Inlines
pHardBreak = do -- assumes we've parsed \ already
  skipMany spaceOrTab
  endline
  skipMany spaceOrTab
  pure hardBreak

pSoftBreak :: P Inlines
pSoftBreak = do
  endline
  skipMany spaceOrTab
  (mempty <$ eof) <|> pure softBreak

pSymbol :: P Inlines
pSymbol = do
  asciiChar ':'
  bs <- byteStringOf $ skipSome (skipSatisfyByte
                                    (\c -> c == '+' || c == '-' ||
                                           c == '_' ||
                                         (isAscii c && isAlphaNum c)))
  asciiChar ':'
  pure $ symbol bs

pMath :: P Inlines
pMath = do
  asciiChar '$'
  mathStyle <- (DisplayMath <$ asciiChar '$') <|> pure InlineMath
  verb <- pVerbatim
  case unMany verb of
         [Node pos attr (Verbatim bs)] ->
              pure $ Many $ Seq.singleton $ Node pos attr (Math mathStyle bs)
         _ -> pure $ (case mathStyle of
                        DisplayMath -> str "$$"
                        _ -> str "$") <> verb

{-# INLINE bracesRequired #-}
bracesRequired :: Char -> Bool
bracesRequired '=' = True
bracesRequired '+' = True
bracesRequired '-' = True
bracesRequired _ = False

pCloser :: P ()
pCloser = do
  delims <- activeDelims <$> getState
  if Set.null delims
     then mzero
     else do
       openerHadBrace <- asum $
         map (\(Delim hadBrace c) -> hadBrace <$ asciiChar c) (F.toList delims)
       mblastc <- peekBack
       let afterws = maybe True isWs mblastc
       when ( afterws || openerHadBrace ) $ asciiChar '}'

pEmph, pStrong, pSuperscript, pSubscript :: P Inlines
pEmph = pBetween '_' emph
pStrong = pBetween '*' strong
pSuperscript = pBetween '^' superscript
pSubscript = pBetween '~' subscript

pHighlight, pInsert, pDelete :: P Inlines
pHighlight = pBetween '=' highlight
pInsert = pBetween '+' insert
pDelete = pBetween '-' delete

pBetween :: Char -> (Inlines -> Inlines) -> P Inlines
pBetween c constructor = do
  let starter leftBrace = do
        case leftBrace of
          False
            | bracesRequired c -> mzero
            | otherwise -> asciiChar c `notFollowedBy`
                                (ws <|> asciiChar '}')
          True -> asciiChar c `notFollowedBy` asciiChar '}'
  let ender leftBrace = do
        mblastc <- peekBack
        let afterws = maybe True isWs mblastc
        asciiChar c
        if leftBrace
           then asciiChar '}'
           else guard (not afterws) `notFollowedBy` asciiChar '}'
  leftBrace <- (True <$ asciiChar '{') <|> pure False
  starterBs <- (if leftBrace then ("{" <>) else id) <$>
                 byteStringOf (starter leftBrace) `notFollowedBy` pAttributes
                 -- don't let *{.foo} start emphasis, for example
  oldActiveDelims <- activeDelims <$> getState
  updateState $ \st -> st{ activeDelims = Set.insert (Delim leftBrace c)
                                             (activeDelims st) }
  firstIl <- pInline <|> pBetween c constructor -- to allow stacked cases like '**hi**'
  restIls <- many pInline
  let ils = mconcat (firstIl:restIls)
  updateState $ \st -> st{ activeDelims = oldActiveDelims }
  (constructor ils <$ ender leftBrace) <|> pure (str starterBs <> ils)

pTicks :: P Int
pTicks = do
  sp <- getOffset
  skipSome (asciiChar '`')
  ep <- getOffset
  pure (ep - sp)

pVerbatim :: P Inlines
pVerbatim = do
  numticks <- pTicks
  let ender = pTicks >>= guard . (== numticks)
  let content = skipSome (skipSatisfyByte (\c -> c /= '`' && c /= '\\')) <|>
                 (asciiChar '\\' <* anyChar) <|>
                 (fails ender *> skipSome (asciiChar '`'))
  bs <- trimSpaces <$> byteStringOf (skipMany content) <* (ender <|> eof)
  (rawInline <$> pRawAttribute <*> pure bs) <|> pure (verbatim bs)

-- Trim a leading space if first non-space character is `,
-- and similarly for trailing space/last non-space.
trimSpaces :: ByteString -> ByteString
trimSpaces = trimSpaceFront . trimSpaceBack
 where
   trimSpaceFront bs =
        case B8.span (== ' ') bs of
          (a, b) | B8.take 1 b == "`"
                 , not (B8.null a)
            -> B8.drop 1 bs
          _ -> bs
   trimSpaceBack bs =
        case B8.spanEnd (== ' ') bs of
          (a, b) | B8.takeEnd 1 a == "`"
                 , not (B8.null b)
            -> B8.dropEnd 1 bs
          _ -> bs

pRawAttribute :: P Format
pRawAttribute = do
  byteString "{="
  fmt <- Format <$>
             byteStringOf (skipMany (skipSatisfyByte (\c -> c /= '}' &&
                                                 not (isWs c))))
  asciiChar '}'
  pure fmt

pFootnoteReference :: P Inlines
pFootnoteReference = do
  asciiChar '['
  asciiChar '^'
  label <- byteStringOf $ skipMany $
             skipSatisfyByte (\c -> c /= ']' && not (isWs c))
  asciiChar ']'
  pure $ footnoteReference label

-- returns Left with parsed content if no ] has been reached, otherwise Right
-- with inner contents.
pBracketed :: P (Either Inlines Inlines)
pBracketed = do
  let starter = asciiChar '['
  let ender = asciiChar ']'
  starterBs <- byteStringOf starter
  oldActiveDelims <- activeDelims <$> getState
  updateState $ \st -> st{ activeDelims = Set.insert (Delim False ']') (activeDelims st) }
  ils <- mconcat <$> many pInline
  updateState $ \st -> st{ activeDelims = oldActiveDelims }
  (Right ils <$ ender) <|> pure (Left (str starterBs <> ils))

pImage :: P Inlines
pImage = do
  asciiChar '!'
  (res, raw) <- withByteString pBracketed
  case res of
    Left ils -> pure (str "!" <> ils)
    Right ils ->
            ((str "!" <>) <$> pAddAttributes (span_ ils))
        <|> (image ils <$> (pDestination <|> pReference raw))
        <|> pure (str "![" <> ils <> str "]")

pAutolink :: P Inlines
pAutolink = do
  asciiChar '<'
  res <- byteStringOf $ skipSome $ skipSatisfyByte (\c -> c /= '>' && c /= '<')
  asciiChar '>'
  let url = B8.filter (\c -> c /= '\n' && c /= '\r') res
  case B8.find (\c -> c == '@' || c == ':' || c == '.') url of
    Just '@' -> pure $ emailLink url
    Just _ -> pure $ urlLink url
    Nothing -> mzero

pLinkOrSpan :: P Inlines
pLinkOrSpan = do
  (res, raw) <- withByteString pBracketed
  case res of
    Left ils -> pure ils
    Right ils ->
            (span_ ils <$ lookahead (asciiChar '{'))
        <|> (link ils <$> (pDestination <|> pReference raw))
        <|> pure (str "[" <> ils <> str "]")

-- We allow balanced pairs of parens inside.
pDestination :: P Target
pDestination = do
  asciiChar '('
  res <- byteStringOf $ pInBalancedParens 0
  asciiChar ')'
  pure $ Direct (snd (handleEscapesAndNewlines res))
 where
  handleEscapesAndNewlines = B8.foldl' go (False, mempty)
  go (esc, bs) '\n' = (esc, bs)
  go (esc, bs) '\r' = (esc, bs)
  go (True, bs) c = (False, bs `B8.snoc` c)
  go (False, bs) '\\' = (True, bs)
  go (False, bs) c = (False, bs `B8.snoc` c)

pInBalancedParens :: Int -> P ()
pInBalancedParens nestlevel =
  (guard (nestlevel == 0) <* lookahead (asciiChar ')')) <|>
    do lev <-   (nestlevel <$ (fails pCloser *>
                               -- but see https://github.com/jgm/djot/discussions/247
                               skipSatisfyByte
                                 (\c -> c /= '(' && c /= ')' && c /= '\\')))
            <|> (nestlevel <$ (asciiChar '\\' <* anyChar))
            <|> ((nestlevel + 1) <$ asciiChar '(')
            <|> ((nestlevel - 1) <$ asciiChar ')')
       pInBalancedParens lev

pReference :: ByteString -> P Target
pReference rawDescription = do
  asciiChar '['
  bs <- byteStringOf $ pAtMost 400 $ skipSatisfyByte
           (\c -> c /= '[' && c /= ']')
  asciiChar ']'
  let label = normalizeLabel $
              if B.null bs
                 then B.drop 1 $ B.dropEnd 1
                               $ B8.filter (/= '\n') rawDescription
                 else bs
  pure $ Reference label

pAtMost :: Int -> P () -> P ()
pAtMost n pa = optional_ (pa *> when (n > 0) (pAtMost ( n - 1 ) pa))

pOpenDoubleQuote :: P ()
pOpenDoubleQuote = do
  lbrace <- (True <$ asciiChar '{') <|> pure False
  asciiChar '"'
  rbrace <- (True <$ asciiChar '}') <|> pure False
  guard $ lbrace || not rbrace

pCloseDoubleQuote :: P ()
pCloseDoubleQuote = do
  mblastc <- peekBack
  let whitespaceBefore = maybe True isWs mblastc
  lbrace <- (True <$ asciiChar '{') <|> pure False
  asciiChar '"'
  rbrace <- (True <$ asciiChar '}') <|> pure False
  whitespaceAfter <- (True <$ lookahead (skipSatisfyByte isWs)) <|> pure False
  guard $ not lbrace && (rbrace || not whitespaceBefore || whitespaceAfter)

pDoubleQuote :: P Inlines
pDoubleQuote = (do
  pOpenDoubleQuote
  contents <- mconcat <$> many (fails pCloseDoubleQuote *> pInline)
  (doubleQuoted contents <$ pCloseDoubleQuote)
    <|> pure (openDoubleQuote <> contents))
 <|> (closeDoubleQuote <$ asciiChar '"')

openDoubleQuote, closeDoubleQuote :: Inlines
openDoubleQuote = str "\226\128\156" -- utf8 0x201C
closeDoubleQuote = str "\226\128\157" -- utf8 0x201D

pOpenSingleQuote :: P ()
pOpenSingleQuote = do
  lastc <- fromMaybe '\n' <$> peekBack
  let openContext = lastc == '\t' || lastc == '\r' ||
                    lastc == '\n' || lastc == ' ' ||
                    lastc == '"' || lastc == '\'' ||
                    lastc == '(' || lastc == '[' || lastc == '\0'
  lbrace <- (True <$ asciiChar '{') <|> pure False
  asciiChar '\''
  rbrace <- (True <$ asciiChar '}') <|> pure False
  guard $ lbrace || (openContext && not rbrace)

pCloseSingleQuote :: P ()
pCloseSingleQuote = do
  mblastc <- peekBack
  let whitespaceBefore = maybe True isWs mblastc
  lbrace <- (True <$ asciiChar '{') <|> pure False
  asciiChar '\''
  rbrace <- (True <$ asciiChar '}') <|> pure False
  letterAfter <- (True <$ lookahead (satisfy isLetter)) <|> pure False
  guard $ not lbrace && (rbrace || not (whitespaceBefore || letterAfter))

pSingleQuote :: P Inlines
pSingleQuote = (do
  pOpenSingleQuote
  contents <- mconcat <$> many (fails pCloseSingleQuote *> pInline)
  (singleQuoted contents <$ pCloseSingleQuote)
    <|> pure (closeSingleQuote <> contents))
 <|> (closeSingleQuote <$ asciiChar '\'')

closeSingleQuote :: Inlines
closeSingleQuote = str "\226\128\153" -- utf8 0x2019

pHyphens :: P Inlines
pHyphens = do
  numHyphens <- length <$> some hyphen
  pure $ str $ go numHyphens
    where
     emdash = "\226\128\148" -- utf8 0x2014
     endash = "\226\128\147" -- utf8 0x2013
     hyphen = asciiChar '-' `notFollowedBy` asciiChar '}'
     go 1 = "-"
     go n | n `mod` 3 == 0
          = mconcat (replicate (n `Prelude.div` 3) emdash)
          | n `mod` 2 == 0
          = mconcat (replicate (n `Prelude.div` 2) endash)
          | n `mod` 3 == 2
          = mconcat (replicate (n `Prelude.div` 3) emdash) <> endash
          | n `mod` 3 == 1
          = mconcat (replicate (n `Prelude.div` 3 - 1) emdash) <>
              endash <> endash
          | otherwise
          = emdash <> go (n - 3)

pEllipses :: P Inlines
pEllipses = str "\226\128\166" {- utf8 0x2026 -} <$ byteString "..."

stripEndChunks :: Seq Chunk -> Seq Chunk
stripEndChunks cs =
  case Seq.viewr cs of
    initial Seq.:> c ->
      initial Seq.|> c{ chunkBytes = B8.dropWhileEnd isWs (chunkBytes c) }
    _ -> cs