Sources.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Sources
   Copyright   : Copyright (C) 2021-2024 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

Defines Sources object to be used as input to pandoc parsers and redefines Char
parsers so they get source position information from it.
-}

module Text.Pandoc.Sources
  ( Sources(..)
  , ToSources(..)
  , UpdateSourcePos(..)
  , sourcesToText
  , initialSourceName
  , addToSources
  , ensureFinalNewlines
  , addToInput
  , satisfy
  , takeWhileP
  , takeWhile1P
  , oneOf
  , noneOf
  , anyChar
  , char
  , string
  , newline
  , space
  , spaces
  , letter
  , digit
  , hexDigit
  , alphaNum
  )
where
import qualified Text.Parsec as P
import Text.Parsec (Stream(..), ParsecT)
import Text.Parsec.Prim (mkPT, Consumed(..), Reply(..), State(..))
import Text.Parsec.Error (ParseError, newErrorMessage, Message(SysUnExpect))
import Text.Parsec.Pos as P
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.Char (isSpace, isLetter, isAlphaNum, isDigit, isHexDigit)
import Data.String (IsString(..))
import qualified Data.List.NonEmpty as NonEmpty

-- | A list of inputs labeled with source positions.  It is assumed
-- that the 'Text's have @\n@ line endings.
newtype Sources = Sources { unSources :: [(SourcePos, Text)] }
  deriving (Show, Semigroup, Monoid)

instance Monad m => Stream Sources m Char where
  uncons (Sources []) = return Nothing
  uncons (Sources ((pos,t):rest)) =
    case T.uncons t of
      Nothing -> uncons (Sources rest)
      Just (c,t') -> return $ Just (c, Sources ((pos,t'):rest))

instance IsString Sources where
  fromString s = Sources [(P.initialPos "", T.pack (filter (/='\r') s))]

class ToSources a where
  toSources :: a -> Sources

instance ToSources Text where
  toSources t = Sources [(P.initialPos "", T.filter (/='\r') t)]

instance ToSources [(FilePath, Text)] where
  toSources = Sources
            . map (\(fp,t) ->
                    (P.initialPos fp, T.snoc (T.filter (/='\r') t) '\n'))

instance ToSources Sources where
  toSources = id

sourcesToText :: Sources -> Text
sourcesToText (Sources xs) = mconcat $ map snd xs

addToSources :: Monad m => SourcePos -> Text -> ParsecT Sources u m ()
addToSources pos t = do
  curpos <- P.getPosition
  Sources xs <- P.getInput
  let xs' = case xs of
               [] -> []
               ((_,t'):rest) -> (curpos,t'):rest
  P.setInput $ Sources ((pos, T.filter (/='\r') t):xs')

ensureFinalNewlines :: Int -- ^ number of trailing newlines
                    -> Sources
                    -> Sources
ensureFinalNewlines n (Sources xs) =
  case NonEmpty.nonEmpty xs of
    Nothing -> Sources [(initialPos "", T.replicate n "\n")]
    Just lst ->
      case NonEmpty.last lst of
        (spos, t) ->
          case T.length (T.takeWhileEnd (=='\n') t) of
            len | len >= n -> Sources xs
                | otherwise -> Sources (NonEmpty.init lst ++
                                        [(spos,
                                          t <> T.replicate (n - len) "\n")])

class UpdateSourcePos s c where
  updateSourcePos :: SourcePos -> c -> s -> SourcePos

instance UpdateSourcePos Text Char where
   updateSourcePos pos c _ = updatePosChar pos c

instance UpdateSourcePos [Char] Char where
   updateSourcePos pos c _ = updatePosChar pos c

instance UpdateSourcePos BS.ByteString Char where
   updateSourcePos pos c _ = updatePosChar pos c

instance UpdateSourcePos BL.ByteString Char where
   updateSourcePos pos c _ = updatePosChar pos c

instance UpdateSourcePos Sources Char where
   updateSourcePos pos c sources =
     case sources of
       Sources [] -> updatePosChar pos c
       Sources ((_,t):(pos',_):_)
         | T.null t  -> pos'
       Sources _ ->
           case c of
             '\n' -> incSourceLine (setSourceColumn pos 1) 1
             '\t' -> incSourceColumn pos (4 - ((sourceColumn pos - 1) `mod` 4))
             _    -> incSourceColumn pos 1

-- | Get name of first source in 'Sources'.
initialSourceName :: Sources -> FilePath
initialSourceName (Sources []) = ""
initialSourceName (Sources ((pos,_):_)) = sourceName pos

-- | Add some text to the beginning of the input sources.
-- This simplifies code that expands macros.
addToInput :: Monad m => Text -> ParsecT Sources u m ()
addToInput t = do
  Sources xs <- P.getInput
  case xs of
    [] -> P.setInput $ Sources [(initialPos "",t)]
    (pos,t'):rest -> P.setInput $ Sources ((pos, t <> t'):rest)

-- We need to redefine the parsers in Text.Parsec.Char so that they
-- update source positions properly from the Sources stream.

satisfy :: (Monad m, Stream s m Char, UpdateSourcePos s Char)
         => (Char -> Bool) -> ParsecT s u m Char
satisfy f = P.tokenPrim show updateSourcePos matcher
 where
  matcher !c = if f c then Just c else Nothing

-- | Consume characters while the predicate holds, returning them as
-- a 'Text'.  Always succeeds (returning an empty 'Text' if no
-- characters match).  Equivalent to @'Data.Text.pack' \<$> 'P.many'
-- ('satisfy' f)@ (including source position and error behavior), but
-- faster, because it processes whole chunks of text at a time.
takeWhileP :: Monad m => (Char -> Bool) -> ParsecT Sources u m Text
takeWhileP f = mkPT $ \st ->
  case spanSources f st of
    (t, st', err)
      | T.null t  -> return (Empty (return (Ok t st' err)))
      | otherwise -> return (Consumed (return (Ok t st' err)))

-- | Like 'takeWhileP', but requires at least one matching character.
-- Equivalent to @'Data.Text.pack' \<$> 'P.many1' ('satisfy' f)@.
takeWhile1P :: Monad m => (Char -> Bool) -> ParsecT Sources u m Text
takeWhile1P f = mkPT $ \st ->
  case spanSources f st of
    (t, st', err)
      | T.null t  -> return (Empty (return (Error err)))
      | otherwise -> return (Consumed (return (Ok t st' err)))

-- Consume characters matching the predicate from the beginning of
-- the input, returning the consumed text, the updated parser state,
-- and the error that a corresponding sequence of 'satisfy' parsers
-- would have recorded at the position where it stopped.
spanSources :: (Char -> Bool)
            -> State Sources u
            -> (Text, State Sources u, ParseError)
spanSources f (State (Sources input0) pos0 usr) = go pos0 input0 []
 where
  -- pos and committed are the position and input after the last
  -- consumed character (uncons drops leading empty chunks only when a
  -- character is actually consumed, so they must be retained if we
  -- stop at a chunk boundary).
  go !pos committed acc =
    case dropWhile (T.null . snd) committed of
      [] -> stop pos committed acc ""
      (p, t) : rest ->
        case T.span f t of
          (pre, post)
            | T.null pre -> stop pos committed acc (show (T.head t))
            | T.null post ->
                -- consumed the whole chunk: as with 'satisfy', the
                -- position jumps to the stored position of the next
                -- chunk, if any.
                let pos' = case rest of
                             (pnext, _) : _ -> pnext
                             []             -> advancePos pos pre
                in go pos' ((p, post) : rest) (pre : acc)
            | otherwise ->
                let pos' = advancePos pos pre
                in stop pos' ((p, post) : rest) (pre : acc)
                        (show (T.head post))
  stop pos committed acc msg =
    ( case acc of
        []  -> mempty
        [t] -> t
        _   -> T.concat (reverse acc)
    , State (Sources committed) pos usr
    , newErrorMessage (SysUnExpect msg) pos )

-- Advance a source position over a stretch of text, using the same
-- position updates as the 'UpdateSourcePos' instance for 'Sources'.
advancePos :: SourcePos -> Text -> SourcePos
advancePos pos t
  | T.any (\c -> c == '\n' || c == '\t') t = T.foldl' advanceChar pos t
  | otherwise = incSourceColumn pos (T.length t)
 where
  advanceChar p c =
    case c of
      '\n' -> incSourceLine (setSourceColumn p 1) 1
      '\t' -> incSourceColumn p (4 - ((sourceColumn p - 1) `mod` 4))
      _    -> incSourceColumn p 1

oneOf :: (Monad m, Stream s m Char, UpdateSourcePos s Char)
      => [Char] -> ParsecT s u m Char
oneOf cs = satisfy (`elem` cs)

noneOf :: (Monad m, Stream s m Char, UpdateSourcePos s Char)
       => [Char] -> ParsecT s u m Char
noneOf cs = satisfy (`notElem` cs)

anyChar :: (Monad m, Stream s m Char, UpdateSourcePos s Char)
        => ParsecT s u m Char
anyChar = satisfy (const True)

char :: (Monad m, Stream s m Char, UpdateSourcePos s Char)
     => Char -> ParsecT s u m Char
char c = satisfy (== c)

string :: (Monad m, Stream s m Char, UpdateSourcePos s Char)
       => [Char] -> ParsecT s u m [Char]
string = mapM char

newline :: (Monad m, Stream s m Char, UpdateSourcePos s Char)
        => ParsecT s u m Char
newline = satisfy (== '\n')

space :: (Monad m, Stream s m Char, UpdateSourcePos s Char)
      => ParsecT s u m Char
space = satisfy isSpace

spaces :: (Monad m, Stream s m Char, UpdateSourcePos s Char)
       => ParsecT s u m ()
spaces = P.skipMany space P.<?> "white space"

letter :: (Monad m, Stream s m Char, UpdateSourcePos s Char)
       => ParsecT s u m Char
letter = satisfy isLetter

alphaNum :: (Monad m, Stream s m Char, UpdateSourcePos s Char)
         => ParsecT s u m Char
alphaNum = satisfy isAlphaNum

digit :: (Monad m, Stream s m Char, UpdateSourcePos s Char)
      => ParsecT s u m Char
digit = satisfy isDigit

hexDigit :: (Monad m, Stream s m Char, UpdateSourcePos s Char)
         => ParsecT s u m Char
hexDigit = satisfy isHexDigit