Escape.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilyDependencies #-}
module Text.Pandoc.Readers.Roff.Escape
  ( escape,
    escapeArg,
    escIgnore,
    RoffLikeLexer(..),
  )
where
import Text.Pandoc.Class.PandocMonad
    ( PandocMonad(..), report, PandocMonad(..), report )
import Control.Monad
    ( mzero, mplus, mzero, mplus )
import Data.Char (chr, isAscii, isAlphaNum)
import qualified Data.Map as M
import qualified Data.Text as T
import Text.Pandoc.Logging (LogMessage(..))
import Text.Pandoc.Parsing
import Text.Pandoc.Shared (safeRead)
import qualified Data.Text.Normalize as Normalize
import Text.Pandoc.RoffChar (characterCodes, combiningAccents)

-- | Functions and typeclass for escaping special characters in languages
-- that inherit the Roff syntax.
--
-- For various reasons, the mdoc reader doesn't directly reuse the previously
-- existing roff lexer. The main one is to make it possible to simultaneously
-- process roff escapes and to tokenize mdoc macros correctly based on the
-- control line contents. The extracted interface here allows the same `escape`
-- function to work with lexers that target different token types and support
-- different subsets of the original roff language.

type Lexer m x = ParsecT Sources (State x) m

-- | Lexers for Roff macro
class (Monoid (Token x)) => RoffLikeLexer x where
  -- | Type family for the lexer state
  type State x = a | a -> x
  -- | Type family for the token type being lexed
  type Token x = a | a -> x
  -- | Turn a `T.Text` into a token of the output
  emit :: T.Text -> Token x
  -- | Attempt to parse a roff predefined string sequence and push its expansion
  -- onto the input stream.
  expandString :: PandocMonad m => Lexer m x ()
  -- | Parse the name of a defined string and return its expansion as a `Token`
  escString :: PandocMonad m => Lexer m x (Token x)
  -- | Parse the escape character
  backslash :: PandocMonad m => Lexer m x ()
  -- | If the given custom macro is defined in this document, emit a
  -- tokenized "1", otherwise emit a tokenized "0", implementing the roff
  -- escape @\A@.
  checkDefined :: PandocMonad m => T.Text -> Lexer m x (Token x)
  -- | Output an appropriate token for the @\E@ escape sequence. In roff, @\E@
  -- is an "escape character intended to not be interpreted in copy mode".
  -- If the lexer being defined doesn't implement copy mode, @\E@ can just be
  -- lexed by 'backslash'
  escE :: PandocMonad m => Lexer m x (Token x)
  -- | Lex the low-level roff font selection escape @\f@.
  escFont :: PandocMonad m => Lexer m x (Token x)


characterCodeMap :: M.Map T.Text Char
characterCodeMap =
  M.fromList $ map (\(x,y) -> (y,x)) characterCodes

combiningAccentsMap :: M.Map T.Text Char
combiningAccentsMap =
  M.fromList $ map (\(x,y) -> (y,x)) combiningAccents

escape ::  (PandocMonad m, RoffLikeLexer x) => Lexer m x (Token x)
escape = try $ do
  backslash
  escapeGlyph <|> escapeNormal

escapeGlyph :: (PandocMonad m, RoffLikeLexer x) => Lexer m x (Token x)
escapeGlyph = do
  c <- lookAhead (oneOf ['[','('])
  escapeArg >>= resolveGlyph c

resolveGlyph :: (PandocMonad m, RoffLikeLexer x) => Char -> T.Text -> Lexer m x (Token x)
resolveGlyph delimChar glyph = do
  let cs = T.replace "_u" " u" glyph -- unicode glyphs separated by _
  (case T.words cs of
      []  -> mzero
      [s] -> case M.lookup s characterCodeMap `mplus` readUnicodeChar s of
               Nothing -> mzero
               Just c  -> return $ emit $ T.singleton c
      (s:ss) -> do
        basechar <- case M.lookup s characterCodeMap `mplus`
                         readUnicodeChar s of
                      Nothing ->
                        case T.unpack s of
                          [ch] | isAscii ch && isAlphaNum ch ->
                                 return ch
                          _ -> mzero
                      Just c  -> return c
        let addAccents [] xs = return $ Normalize.normalize Normalize.NFC $
                                        T.reverse xs
            addAccents (a:as) xs =
              case M.lookup a combiningAccentsMap `mplus` readUnicodeChar a of
                Just x  -> addAccents as $ T.cons x xs
                Nothing -> mzero
        addAccents ss (T.singleton basechar) >>= \xs -> return $ emit xs)
      <|> case delimChar of
            '['  -> escUnknown ("\\[" <> glyph <> "]")
            '('  -> escUnknown ("\\(" <> glyph)
            '\'' -> escUnknown ("\\C'" <> glyph <> "'")
            _    -> Prelude.fail "resolveGlyph: unknown glyph delimiter"

readUnicodeChar :: T.Text -> Maybe Char
readUnicodeChar t = case T.uncons t of
  Just ('u', cs) | T.length cs > 3 -> chr <$> safeRead ("0x" <> cs)
  _ -> Nothing

escapeNormal :: (PandocMonad m, RoffLikeLexer x) => Lexer m x (Token x)
escapeNormal = do
  c <- noneOf "{}"
  optional expandString
  let groffSkip = [escapeArg, countChar 1 (satisfy (/='\n'))]
  case c of
    ' ' -> return $ emit " " -- mandoc_char(7) says this should be a nonbreaking space
    '"' -> mempty <$ skipMany (satisfy (/='\n')) -- line comment
    '#' -> mempty <$ manyTill anyChar newline
    '%' -> return mempty  -- optional hyphenation
    '&' -> return mempty  -- nonprintable zero-width
    ')' -> return mempty  -- nonprintable zero-width
    '*' -> escString
    ',' -> return mempty  -- to fix spacing after roman
    '-' -> return $ emit "-"
    '.' -> return $ emit "."
    '/' -> return mempty  -- to fix spacing before roman
    '0' -> return $ emit "\x2007" -- digit-width space
    ':' -> return mempty  -- zero-width break
    'A' -> quoteArg >>= checkDefined
    'B' -> escIgnore 'B' [quoteArg]
    'C' -> quoteArg >>= resolveGlyph '\''
    'D' -> escIgnore 'D' [quoteArg]
    'E' -> escE
    'F' -> escIgnore 'F' groffSkip
    'H' -> escIgnore 'H' [quoteArg]
    'L' -> escIgnore 'L' [quoteArg]
    'M' -> escIgnore 'M' groffSkip
    'N' -> escIgnore 'N' [quoteArg]
    'O' -> escIgnore 'O' [countChar 1 (oneOf ['0','1'])]
    'R' -> escIgnore 'R' [quoteArg]
    'S' -> escIgnore 'S' [quoteArg]
    'V' -> escIgnore 'V' groffSkip
    'X' -> escIgnore 'X' [quoteArg]
    'Y' -> escIgnore 'Y' groffSkip
    'Z' -> escIgnore 'Z' [quoteArg]
    '\'' -> return $ emit "'"
    '\n' -> return mempty  -- line continuation
    '^' -> return $ emit "\x200A" -- 1/12 em space
    '_' -> return $ emit "_"
    '`' -> return $ emit "`"
    'a' -> return mempty  -- "non-interpreted leader character"
    'b' -> escIgnore 'b' [quoteArg]
    'c' -> return mempty  -- interrupt text processing
    'd' -> escIgnore 'd' [] -- forward down 1/2em
    'e' -> return $ emit "\\"
    'f' -> escFont
    'g' -> escIgnore 'g' groffSkip
    'h' -> escIgnore 'h' [quoteArg]
    'k' -> escIgnore 'k' groffSkip
    'l' -> escIgnore 'l' [quoteArg]
    'm' -> escIgnore 'm' groffSkip
    'n' -> escIgnore 'm' groffSkip
    'o' -> escIgnore 'o' [quoteArg]
    'p' -> escIgnore 'p' []
    'r' -> escIgnore 'r' []
    's' -> escIgnore 's' [escapeArg, signedNumber]
    't' -> return $ emit "\t"
    'u' -> escIgnore 'u' []
    'v' -> escIgnore 'v' [quoteArg]
    'w' -> escIgnore 'w' [quoteArg]
    'x' -> escIgnore 'x' [quoteArg]
    'z' -> escIgnore 'z' [countChar 1 anyChar]
    '|' -> return $ emit "\x2006" --1/6 em space
    '~' -> return $ emit "\160" -- nonbreaking space
    '\\' -> return $ emit "\\"
    _   -> return $ emit $ T.singleton c
    -- man 7 groff: "If  a  backslash  is followed by a character that
    -- does not constitute a defined escape sequence, the backslash
    -- is  silently  ignored  and  the character maps to itself."

escIgnore :: (PandocMonad m, RoffLikeLexer x)
          => Char
          -> [Lexer m x T.Text]
          -> Lexer m x (Token x)
escIgnore c argparsers = do
  pos <- getPosition
  arg <- snd <$> withRaw (choice argparsers) <|> return ""
  report $ SkippedContent ("\\" <> T.cons c arg) pos
  return mempty

escUnknown :: (PandocMonad m, RoffLikeLexer x) => T.Text -> Lexer m x (Token x)
escUnknown s = do
  pos <- getPosition
  report $ SkippedContent s pos
  return $ emit "\xFFFD"

signedNumber :: (PandocMonad m, RoffLikeLexer x) => Lexer m x T.Text
signedNumber = try $ do
  sign <- option "" ("-" <$ char '-' <|> "" <$ char '+')
  ds <- many1Char digit
  return (sign <> ds)

-- Parses: [..] or (..
escapeArg :: (PandocMonad m, RoffLikeLexer x) => Lexer m x T.Text
escapeArg = choice
    [ char '[' *> optional expandString *>
                  manyTillChar (noneOf ['\n',']']) (char ']')
    , char '(' *> optional expandString *>
                  countChar 2 (satisfy (/='\n'))
    ]

-- Parses: '..'
quoteArg :: (PandocMonad m, RoffLikeLexer x) => Lexer m x T.Text
quoteArg = char '\'' *> manyTillChar (noneOf ['\n','\'']) (char '\'')