Lex.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{- |
   Module      : Text.Pandoc.Readers.Mdoc.Lex
   Copyright   : Copyright (C) 2024 Evan Silberman
   License     : GNU GPL, version 2 or above

   Maintainer  : Evan Silberman <evan@jklol.net>
   Stability   : WIP
   Portability : portable

Tokenizer for mdoc
-}
module Text.Pandoc.Readers.Mdoc.Lex
  ( MdocToken(..)
  , MdocTokens(..)
  , DelimSide(..)
  , lexMdoc
  , toString
  )
where

import Control.Monad (void, guard, when)
import Control.Monad.Except (throwError)
import Text.Pandoc.Class.PandocMonad (PandocMonad(..))
import Data.Char (isAlphaNum)
import Data.Maybe (isJust)
import qualified Data.Text as T
import Text.Pandoc.Options
import Text.Pandoc.Parsing
import Text.Pandoc.Readers.Roff.Escape
import Text.Pandoc.Readers.Mdoc.Macros
import qualified Data.Sequence as Seq

-- As a higher level language with a wealth of semantic macros, mdoc
-- discourages authors from falling back to low-level roff features like font
-- selection, custom macros, defined strings, etc. Pandoc's mdoc reader is
-- accordingly implemented as a high-level interpreter of mdoc's semantic macros
-- and almost no raw roff requests are supported.
--
-- tbl(7) and eqn(7) macros are rare but not completely unseen in mdoc manuals.
-- they are not yet implemented. most use of tbl macros in mdoc could probably
-- be replaced with .Bl -column

data DelimSide = Open | Middle | Close deriving (Show, Eq)

-- | Tokens for Mdoc documents
data MdocToken = Str T.Text SourcePos -- ^ The contents of a text line
               | Macro T.Text SourcePos  -- ^ A macro to be processed
               | Lit T.Text SourcePos  -- ^ Literal text on a control line
               | Blank SourcePos  -- ^ A blank line
               | Delim DelimSide T.Text SourcePos  -- ^ A delimiter character
               | Eol  -- ^ The end of a control line
               deriving Show

toString :: MdocToken -> T.Text
toString (Str x _) = x
toString (Macro x _) = x
toString (Lit x _) = x
toString (Delim _ x _) = x
toString Blank{} = mempty
toString Eol = mempty

newtype MdocTokens = MdocTokens { unMdocTokens :: Seq.Seq MdocToken }
        deriving (Show, Semigroup, Monoid)

singleTok :: MdocToken -> MdocTokens
singleTok t = MdocTokens (Seq.singleton t)

type Lexer m = ParsecT Sources () m

instance RoffLikeLexer MdocTokens where
  -- This is a bit confusing. We're lexing to MdocTokens, but for escaping
  -- purposes we just want Texts.
  type Token MdocTokens = T.Text
  -- We don't need a state
  type State MdocTokens = ()
  -- We don't support predefined string expansion
  expandString = return ()
  escString = return mempty
  -- what token type the unescaped text gets wrapped in is decided by other
  -- parts of the lexer.
  emit = id
  -- All escapes are resolved in the lexer and we never need to emit anything,
  -- vs. the roff lexer which has to push the backlashes to the output while
  -- in copy mode.
  backslash = (mempty <* char '\\') <|> (mempty <* string "\\E")
  -- We don't support macro definition and we don't output anything for \A
  checkDefined = const mempty
  -- We don't support copy mode and \E is treated as backslash
  escE = return mempty
  -- We don't support low-level font selection
  escFont = escIgnore 'f' [escapeArg, countChar 1 (satisfy (/='\n'))]

eofline :: (Stream s m Char, UpdateSourcePos s Char) => ParsecT s u m MdocToken
eofline = do
  void newline <|> eof
  return Eol

lexComment :: PandocMonad m => Lexer m MdocTokens
lexComment = do
  try $ string ".\\\""
  skipMany $ noneOf "\n"
  eofline
  return mempty

argText :: PandocMonad m => Lexer m T.Text
argText = do
  beg <- escape <|> regularText
  end <- mconcat <$> many (escape <|> regularText <|> quoteChar)
  return $ beg <> end

spaceTabChar :: PandocMonad m => Lexer m T.Text
spaceTabChar = T.singleton <$> spaceChar

quotedArg :: PandocMonad m => Lexer m T.Text
quotedArg = do
  quoteChar
  t <- mconcat <$> many (try innerQuote <|> escape <|> regularText <|> spaceTabChar)
  quoteChar
  notFollowedBy quoteChar
  return t
  where
    innerQuote = do
      string "\"\""
      return "\""

anyText :: PandocMonad m => Lexer m T.Text
anyText = escape <|> regularText <|> quoteChar <|> spaceTabChar

regularText :: PandocMonad m => Lexer m T.Text
regularText = many1Char $ noneOf "\n\r\t \\\""

quoteChar :: PandocMonad m => Lexer m T.Text
quoteChar = T.singleton <$> char '"'

mdocToken :: PandocMonad m => Lexer m MdocTokens
mdocToken = lexComment <|> lexControlLine <|> lexTextLine

lexMacroName :: PandocMonad m => Lexer m T.Text
lexMacroName = many1Char (satisfy isMacroChar)
  where
    isMacroChar '%' = True
    isMacroChar x = isAlphaNum x

lexMacro :: PandocMonad m => Lexer m MdocToken
lexMacro = do
  pos <- getPosition
  name <- lexMacroName
  eof <|> void (lookAhead (spaceChar <|> newline))
  skipSpaces
  return $ Macro name pos

lexCallableMacro :: PandocMonad m => Lexer m MdocToken
lexCallableMacro = do
  pos <- getPosition
  q <- optionMaybe quoteChar
  name <- lexMacroName
  when (isJust q) (void quoteChar)
  eof <|> void (lookAhead (spaceChar <|> newline))
  skipSpaces
  guard $ isCallableMacro name
  return $ Macro name pos

lexDelim :: (PandocMonad m) => Lexer m MdocToken
lexDelim = do
  pos <- getPosition
  q <- optionMaybe quoteChar
  t <-
    Delim Open <$> oneOfStrings ["(", "["]
      <|> Delim Close <$> oneOfStrings [".", ",", ":", ";", ")", "]", "?", "!"]
      <|> Delim Middle <$> textStr "|"
  when (isJust q) (void quoteChar)
  eof <|> void (lookAhead (spaceChar <|> newline))
  skipSpaces
  return $ t pos

lexLit :: PandocMonad m => Lexer m MdocToken
lexLit = do
  pos <- getPosition
  t <- argText <|> quotedArg
  skipSpaces
  return $ Lit t pos

lexTextLine :: PandocMonad m => Lexer m MdocTokens
lexTextLine = do
  pos <- getPosition
  guard $ sourceColumn pos == 1
  t <- mconcat <$> many anyText
  eofline
  if T.null $ T.strip t
     then return $ singleTok $ Blank pos
     else return $ singleTok $ Str t pos

lexControlLine :: PandocMonad m => Lexer m MdocTokens
lexControlLine = do
  pos <- getPosition
  guard $ sourceColumn pos == 1
  char '.'
  eofline *> mempty <|> do
    m@(Macro name _) <- lexMacro
    -- .Ns macros at the start of a line are ignored. We'd have to look behind
    -- to keep track of the "start of the line" in the parser, so we'll drop
    -- those macros in lexing.
    let start | name == "Ns" = []
              | otherwise = [m]
    let parsed = isParsedMacro name
    (wds, e) <- manyUntil (l parsed) eofline
    return $ MdocTokens $ Seq.fromList $ start <> wds <> [e]
      where
        l True = try lexDelim <|> try lexCallableMacro <|> lexLit
        l False = try lexDelim <|> lexLit

-- | Tokenize a string as a sequence of mdoc tokens.
lexMdoc :: PandocMonad m => SourcePos -> T.Text -> m MdocTokens
lexMdoc pos txt = do
  eithertokens <- readWithM (do setPosition pos
                                mconcat <$> manyTill mdocToken eof) def txt
  case eithertokens of
    Left e       -> throwError e
    Right tokenz -> return tokenz