{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Rank2Types #-}
module Text.PariPari.Internal.Combinators (
void
, (<|>)
, empty
, ON.some
, ON.endBy1
, ON.someTill
, ON.sepBy1
, ON.sepEndBy1
, O.optional
, O.many
, O.between
, O.choice
, O.count
, O.count'
, O.eitherP
, O.endBy
, O.manyTill
, O.option
, O.sepBy
, O.sepEndBy
, O.skipMany
, O.skipSome
, O.skipCount
, O.skipManyTill
, O.skipSomeTill
, (<?>)
, getLine
, getCol
, withPos
, withSpan
, getRefCol
, getRefLine
, withRefPos
, align
, indented
, line
, linefold
, digitByte
, integer
, integer'
, decimal
, octal
, hexadecimal
, digit
, sign
, signed
, fractionHex
, fractionDec
, char'
, notChar
, anyChar
, anyAsciiByte
, alphaNumChar
, digitChar
, letterChar
, lowerChar
, upperChar
, symbolChar
, categoryChar
, punctuationChar
, spaceChar
, asciiChar
, satisfy
, asciiSatisfy
, skipChars
, takeChars
, skipCharsWhile
, takeCharsWhile
, skipCharsWhile1
, takeCharsWhile1
, scanChars
, scanChars1
, string
) where
import Control.Applicative (optional)
import Control.Monad (when)
import Control.Monad.Combinators (option, skipCount, skipMany)
import Data.Functor (void)
import Data.Maybe (fromMaybe)
import Data.Word (Word8)
import Prelude hiding (getLine)
import Text.PariPari.Internal.Chunk
import Text.PariPari.Internal.Class
import qualified Control.Monad.Combinators as O
import qualified Control.Monad.Combinators.NonEmpty as ON
import qualified Data.Char as C
type P k a = (forall p. Parser k p => p a)
(<?>) :: Parser k p => p a -> String -> p a
(<?>) = flip label
{-# INLINE (<?>) #-}
infix 0 <?>
getRefLine :: P k Int
getRefLine = _posLine <$> getRefPos
{-# INLINE getRefLine #-}
getRefCol :: P k Int
getRefCol = _posCol <$> getRefPos
{-# INLINE getRefCol #-}
getLine :: P k Int
getLine = _posLine <$> getPos
{-# INLINE getLine #-}
getCol :: P k Int
getCol = _posCol <$> getPos
{-# INLINE getCol #-}
withPos :: Parser k p => p a -> p (Pos, a)
withPos p = do
pos <- getPos
ret <- p
pure (pos, ret)
{-# INLINE withPos #-}
withSpan :: Parser k p => p a -> p (Pos, Pos, a)
withSpan p = do
begin <- getPos
ret <- p
end <- getPos
pure (begin, end, ret)
{-# INLINE withSpan #-}
line :: P k ()
line = do
l <- getLine
rl <- getRefLine
when (l /= rl) $ failWith $ EIndentOverLine rl l
{-# INLINE line #-}
align :: P k ()
align = do
c <- getCol
rc <- getRefCol
when (c /= rc) $ failWith $ EIndentNotAligned rc c
{-# INLINE align #-}
indented :: P k ()
indented = do
c <- getCol
rc <- getRefCol
when (c <= rc) $ failWith $ ENotEnoughIndent rc c
{-# INLINE indented #-}
linefold :: P k ()
linefold = line <|> indented
{-# INLINE linefold #-}
digitByte :: Parser k p => Int -> p Word8
digitByte base = asciiSatisfy (isDigit base)
{-# INLINE digitByte #-}
isDigit :: Int -> Word8 -> Bool
isDigit base b
| base >= 2 && base <= 10 = b >= asc_0 && b <= asc_0 + fromIntegral base - 1
| base <= 36 = (b >= asc_0 && b <= asc_9)
|| ((fromIntegral b :: Word) - fromIntegral asc_A) < fromIntegral (base - 10)
|| ((fromIntegral b :: Word) - fromIntegral asc_a) < fromIntegral (base - 10)
|otherwise = error "Text.PariPari.Internal.Combinators.isDigit: Bases 2 to 36 are supported"
{-# INLINE isDigit #-}
digitToInt :: Int -> Word8 -> Word
digitToInt base b
| n <- (fromIntegral b :: Word) - fromIntegral asc_0, base <= 10 || n <= 9 = n
| n <- (fromIntegral b :: Word) - fromIntegral asc_A, n <= 26 = n + 10
| n <- (fromIntegral b :: Word) - fromIntegral asc_a = n + 10
{-# INLINE digitToInt #-}
digit :: Parser k p => Int -> p Word
digit base = digitToInt base <$> asciiSatisfy (isDigit base)
{-# INLINE digit #-}
integer' :: (Num a, Parser k p) => p sep -> Int -> p (a, Int)
integer' sep base = label (integerLabel base) $ do
d <- digit base
accum 1 $ fromIntegral d
where accum !i !n = next i n <|> pure (n, i)
next !i !n = do
void $ sep
d <- digit base
accum (i + 1) $ n * fromIntegral base + fromIntegral d
{-# INLINE integer' #-}
integer :: (Num a, Parser k p) => p sep -> Int -> p a
integer sep base = label (integerLabel base) $ do
d <- digit base
accum $ fromIntegral d
where accum !n = next n <|> pure n
next !n = do
void $ sep
d <- digit base
accum $ n * fromIntegral base + fromIntegral d
{-# INLINE integer #-}
integerLabel :: Int -> String
integerLabel 2 = "binary integer"
integerLabel 8 = "octal integer"
integerLabel 10 = "decimal integer"
integerLabel 16 = "hexadecimal integer"
integerLabel b = "integer of base " <> show b
decimal :: Num a => P k a
decimal = integer (pure ()) 10
{-# INLINE decimal #-}
octal :: Num a => P k a
octal = integer (pure ()) 8
{-# INLINE octal #-}
hexadecimal :: Num a => P k a
hexadecimal = integer (pure ()) 16
{-# INLINE hexadecimal #-}
sign :: (Parser k f, Num a) => f (a -> a)
sign = (negate <$ asciiByte asc_minus) <|> (id <$ optional (asciiByte asc_plus))
{-# INLINE sign #-}
signed :: (Num a, Parser k p) => p a -> p a
signed p = ($) <$> sign <*> p
{-# INLINE signed #-}
fractionExp :: (Num a, Parser k p) => p expSep -> p digitSep -> p (Maybe a)
fractionExp expSep digitSep = do
e <- optional expSep
case e of
Nothing{} -> pure Nothing
Just{} -> Just <$> signed (integer digitSep 10)
{-# INLINE fractionExp #-}
fraction :: (Num a, Parser k p) => p expSep -> Int -> Int -> p digitSep -> p (Either a (a, Int, a))
fraction expSep expBase mantBasePow digitSep = do
let mantBase = expBase ^ mantBasePow
mant <- integer digitSep mantBase
frac <- optional $ asciiByte asc_point *> option (0, 0) (integer' digitSep mantBase)
expn <- fractionExp expSep digitSep
let (fracVal, fracLen) = fromMaybe (0, 0) frac
expVal = fromMaybe 0 expn
pure $ case (frac, expn) of
(Nothing, Nothing) -> Left mant
_ -> Right ( mant * fromIntegral mantBase ^ fracLen + fracVal
, expBase
, expVal - fromIntegral (fracLen * mantBasePow))
{-# INLINE fraction #-}
fractionDec :: (Num a, Parser k p) => p digitSep -> p (Either a (a, Int, a))
fractionDec sep = fraction (asciiSatisfy (\b -> b == asc_E || b == asc_e)) 10 1 sep <?> "fraction"
{-# INLINE fractionDec #-}
fractionHex :: (Num a, Parser k p) => p digitSep -> p (Either a (a, Int, a))
fractionHex sep = fraction (asciiSatisfy (\b -> b == asc_P || b == asc_p)) 2 4 sep <?> "hexadecimal fraction"
{-# INLINE fractionHex #-}
char' :: Parser k p => Char -> p Char
char' x =
let l = C.toLower x
u = C.toUpper x
in satisfy (\c -> c == l || c == u)
{-# INLINE char' #-}
notChar :: Parser k p => Char -> p Char
notChar c = satisfy (/= c)
{-# INLINE notChar #-}
anyChar :: P k Char
anyChar = satisfy (const True)
{-# INLINE anyChar #-}
anyAsciiByte :: P k Word8
anyAsciiByte = asciiSatisfy (const True)
{-# INLINE anyAsciiByte #-}
alphaNumChar :: P k Char
alphaNumChar = satisfy C.isAlphaNum <?> "alphanumeric character"
{-# INLINE alphaNumChar #-}
letterChar :: P k Char
letterChar = satisfy C.isLetter <?> "letter"
{-# INLINE letterChar #-}
lowerChar :: P k Char
lowerChar = satisfy C.isLower <?> "lowercase letter"
{-# INLINE lowerChar #-}
upperChar :: P k Char
upperChar = satisfy C.isUpper <?> "uppercase letter"
{-# INLINE upperChar #-}
spaceChar :: P k Char
spaceChar = satisfy C.isSpace <?> "space"
{-# INLINE spaceChar #-}
symbolChar :: P k Char
symbolChar = satisfy C.isSymbol <?> "symbol"
{-# INLINE symbolChar #-}
punctuationChar :: P k Char
punctuationChar = satisfy C.isPunctuation <?> "punctuation"
{-# INLINE punctuationChar #-}
digitChar :: Parser k p => Int -> p Char
digitChar base = unsafeAsciiToChar <$> digitByte base
{-# INLINE digitChar #-}
asciiChar :: P k Char
asciiChar = unsafeAsciiToChar <$> anyAsciiByte
{-# INLINE asciiChar #-}
categoryChar :: Parser k p => C.GeneralCategory -> p Char
categoryChar cat = satisfy ((== cat) . C.generalCategory) <?> untitle (show cat)
{-# INLINE categoryChar #-}
untitle :: String -> String
untitle [] = []
untitle (x:xs) = C.toLower x : go xs
where go [] = ""
go (y:ys) | C.isUpper y = ' ' : C.toLower y : untitle ys
| otherwise = y : ys
skipChars :: Parser k p => Int -> p ()
skipChars n = skipCount n anyChar
{-# INLINE skipChars #-}
skipCharsWhile :: Parser k p => (Char -> Bool) -> p ()
skipCharsWhile f = skipMany (satisfy f)
{-# INLINE skipCharsWhile #-}
skipCharsWhile1 :: Parser k p => (Char -> Bool) -> p ()
skipCharsWhile1 f = satisfy f *> skipCharsWhile f
{-# INLINE skipCharsWhile1 #-}
takeChars :: Parser k p => Int -> p k
takeChars n = asChunk (skipChars n) <?> "string of length " <> show n
{-# INLINE takeChars #-}
takeCharsWhile :: Parser k p => (Char -> Bool) -> p k
takeCharsWhile f = asChunk (skipCharsWhile f)
{-# INLINE takeCharsWhile #-}
takeCharsWhile1 :: Parser k p => (Char -> Bool) -> p k
takeCharsWhile1 f = asChunk (skipCharsWhile1 f)
{-# INLINE takeCharsWhile1 #-}
satisfy :: Parser k p => (Char -> Bool) -> p Char
satisfy f = scan $ \c -> if f c then Just c else Nothing
{-# INLINE satisfy #-}
asciiSatisfy :: Parser k p => (Word8 -> Bool) -> p Word8
asciiSatisfy f = asciiScan $ \b -> if f b then Just b else Nothing
{-# INLINE asciiSatisfy #-}
scanChars :: Parser k p => (s -> Char -> Maybe s) -> s -> p s
scanChars f = go
where go s = (scan (f s) >>= go) <|> pure s
{-# INLINE scanChars #-}
scanChars1 :: Parser k p => (s -> Char -> Maybe s) -> s -> p s
scanChars1 f s = scan (f s) >>= scanChars f
{-# INLINE scanChars1 #-}