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
  , 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.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

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