{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Rank2Types #-}
module Text.PariPari.Internal.CharCombinators (
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.Combinators (option, skipCount, skipMany)
import Data.Functor (void)
import Data.Maybe (fromMaybe)
import Data.Semigroup ((<>))
import Data.Word (Word8)
import Text.PariPari.Internal.Chunk
import Text.PariPari.Internal.Class
import Text.PariPari.Internal.ElementCombinators ((<?>))
import qualified Data.Char as C
type CharP k a = (forall p. CharParser k p => p a)
digitByte :: CharParser 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 :: CharParser k p => Int -> p Word
digit base = digitToInt base <$> asciiSatisfy (isDigit base)
{-# INLINE digit #-}
integer' :: (Num a, CharParser 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, CharParser 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 => CharP k a
decimal = integer (pure ()) 10
{-# INLINE decimal #-}
octal :: Num a => CharP k a
octal = integer (pure ()) 8
{-# INLINE octal #-}
hexadecimal :: Num a => CharP k a
hexadecimal = integer (pure ()) 16
{-# INLINE hexadecimal #-}
sign :: (CharParser k f, Num a) => f (a -> a)
sign = (negate <$ asciiByte asc_minus) <|> (id <$ optional (asciiByte asc_plus))
{-# INLINE sign #-}
signed :: (Num a, CharParser k p) => p a -> p a
signed p = ($) <$> sign <*> p
{-# INLINE signed #-}
fractionExp :: (Num a, CharParser 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, CharParser 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, CharParser 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, CharParser 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' :: CharParser 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 :: CharParser k p => Char -> p Char
notChar c = satisfy (/= c)
{-# INLINE notChar #-}
anyChar :: CharP k Char
anyChar = satisfy (const True)
{-# INLINE anyChar #-}
anyAsciiByte :: CharP k Word8
anyAsciiByte = asciiSatisfy (const True)
{-# INLINE anyAsciiByte #-}
alphaNumChar :: CharP k Char
alphaNumChar = satisfy C.isAlphaNum <?> "alphanumeric character"
{-# INLINE alphaNumChar #-}
letterChar :: CharP k Char
letterChar = satisfy C.isLetter <?> "letter"
{-# INLINE letterChar #-}
lowerChar :: CharP k Char
lowerChar = satisfy C.isLower <?> "lowercase letter"
{-# INLINE lowerChar #-}
upperChar :: CharP k Char
upperChar = satisfy C.isUpper <?> "uppercase letter"
{-# INLINE upperChar #-}
spaceChar :: CharP k Char
spaceChar = satisfy C.isSpace <?> "space"
{-# INLINE spaceChar #-}
symbolChar :: CharP k Char
symbolChar = satisfy C.isSymbol <?> "symbol"
{-# INLINE symbolChar #-}
punctuationChar :: CharP k Char
punctuationChar = satisfy C.isPunctuation <?> "punctuation"
{-# INLINE punctuationChar #-}
digitChar :: CharParser k p => Int -> p Char
digitChar base = unsafeAsciiToChar <$> digitByte base
{-# INLINE digitChar #-}
asciiChar :: CharP k Char
asciiChar = unsafeAsciiToChar <$> anyAsciiByte
{-# INLINE asciiChar #-}
categoryChar :: CharParser 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 :: CharParser k p => Int -> p ()
skipChars n = skipCount n anyChar
{-# INLINE skipChars #-}
skipCharsWhile :: CharParser k p => (Char -> Bool) -> p ()
skipCharsWhile f = skipMany (satisfy f)
{-# INLINE skipCharsWhile #-}
skipCharsWhile1 :: CharParser k p => (Char -> Bool) -> p ()
skipCharsWhile1 f = satisfy f *> skipCharsWhile f
{-# INLINE skipCharsWhile1 #-}
takeChars :: CharParser k p => Int -> p k
takeChars n = asChunk (skipChars n) <?> "string of length " <> show n
{-# INLINE takeChars #-}
takeCharsWhile :: CharParser k p => (Char -> Bool) -> p k
takeCharsWhile f = asChunk (skipCharsWhile f)
{-# INLINE takeCharsWhile #-}
takeCharsWhile1 :: CharParser k p => (Char -> Bool) -> p k
takeCharsWhile1 f = asChunk (skipCharsWhile1 f)
{-# INLINE takeCharsWhile1 #-}
satisfy :: CharParser k p => (Char -> Bool) -> p Char
satisfy f = scan $ \c -> if f c then Just c else Nothing
{-# INLINE satisfy #-}
asciiSatisfy :: CharParser k p => (Word8 -> Bool) -> p Word8
asciiSatisfy f = asciiScan $ \b -> if f b then Just b else Nothing
{-# INLINE asciiSatisfy #-}
scanChars :: CharParser k p => (s -> Char -> Maybe s) -> s -> p s
scanChars f = go
where go s = (scan (f s) >>= go) <|> pure s
{-# INLINE scanChars #-}
scanChars1 :: CharParser k p => (s -> Char -> Maybe s) -> s -> p s
scanChars1 f s = scan (f s) >>= scanChars f
{-# INLINE scanChars1 #-}