#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704
#define USE_DEFAULT_SIGNATURES
#endif
#ifdef USE_DEFAULT_SIGNATURES
#endif
module Text.Parser.Char
( CharParsing(..)
, oneOf
, noneOf
, oneOfSet
, noneOfSet
, spaces
, space
, newline
, tab
, upper
, lower
, alphaNum
, letter
, digit
, hexDigit
, octDigit
, decimal
, hexadecimal
, octal
, charLiteral'
, characterChar
, stringLiteral'
, natural'
, integer'
, double'
, naturalOrDouble'
) where
import Control.Applicative
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Lazy as Lazy
import Control.Monad.Trans.State.Strict as Strict
import Control.Monad.Trans.Writer.Lazy as Lazy
import Control.Monad.Trans.Writer.Strict as Strict
import Control.Monad.Trans.RWS.Lazy as Lazy
import Control.Monad.Trans.RWS.Strict as Strict
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Identity
import Data.Char
import Data.CharSet (CharSet(..))
import qualified Data.CharSet as CharSet
import Data.Foldable
import qualified Data.IntSet as IntSet
import Data.Monoid
import Text.Parser.Combinators
oneOf :: CharParsing m => [Char] -> m Char
oneOf xs = oneOfSet (CharSet.fromList xs)
noneOf :: CharParsing m => [Char] -> m Char
noneOf xs = noneOfSet (CharSet.fromList xs)
oneOfSet :: CharParsing m => CharSet -> m Char
oneOfSet (CharSet True _ is) = satisfy (\c -> IntSet.member (fromEnum c) is)
oneOfSet (CharSet False _ is) = satisfy (\c -> not (IntSet.member (fromEnum c) is))
noneOfSet :: CharParsing m => CharSet -> m Char
noneOfSet s = oneOfSet (CharSet.complement s)
spaces :: CharParsing m => m ()
spaces = skipMany space <?> "white space"
space :: CharParsing m => m Char
space = satisfy isSpace <?> "space"
newline :: CharParsing m => m Char
newline = char '\n' <?> "new-line"
tab :: CharParsing m => m Char
tab = char '\t' <?> "tab"
upper :: CharParsing m => m Char
upper = satisfy isUpper <?> "uppercase letter"
lower :: CharParsing m => m Char
lower = satisfy isLower <?> "lowercase letter"
alphaNum :: CharParsing m => m Char
alphaNum = satisfy isAlphaNum <?> "letter or digit"
letter :: CharParsing m => m Char
letter = satisfy isAlpha <?> "letter"
digit :: CharParsing m => m Char
digit = satisfy isDigit <?> "digit"
hexDigit :: CharParsing m => m Char
hexDigit = satisfy isHexDigit <?> "hexadecimal digit"
octDigit :: CharParsing m => m Char
octDigit = satisfy isOctDigit <?> "octal digit"
class Parsing m => CharParsing m where
satisfy :: (Char -> Bool) -> m Char
#ifdef USE_DEFAULT_SIGNATURES
default satisfy :: (MonadTrans t, CharParsing n, m ~ t n) =>
(Char -> Bool) ->
t n Char
satisfy = lift . satisfy
#endif
char :: CharParsing m => Char -> m Char
char c = satisfy (c ==) <?> show [c]
notChar :: CharParsing m => Char -> m Char
notChar c = satisfy (c /=)
anyChar :: CharParsing m => m Char
anyChar = satisfy (const True)
string :: CharParsing m => String -> m String
string s = s <$ try (traverse_ char s) <?> show s
instance CharParsing m => CharParsing (Lazy.StateT s m) where
satisfy = lift . satisfy
char = lift . char
notChar = lift . notChar
anyChar = lift anyChar
string = lift . string
instance CharParsing m => CharParsing (Strict.StateT s m) where
satisfy = lift . satisfy
char = lift . char
notChar = lift . notChar
anyChar = lift anyChar
string = lift . string
instance CharParsing m => CharParsing (ReaderT e m) where
satisfy = lift . satisfy
char = lift . char
notChar = lift . notChar
anyChar = lift anyChar
string = lift . string
instance (CharParsing m, Monoid w) => CharParsing (Strict.WriterT w m) where
satisfy = lift . satisfy
char = lift . char
notChar = lift . notChar
anyChar = lift anyChar
string = lift . string
instance (CharParsing m, Monoid w) => CharParsing (Lazy.WriterT w m) where
satisfy = lift . satisfy
char = lift . char
notChar = lift . notChar
anyChar = lift anyChar
string = lift . string
instance (CharParsing m, Monoid w) => CharParsing (Lazy.RWST r w s m) where
satisfy = lift . satisfy
char = lift . char
notChar = lift . notChar
anyChar = lift anyChar
string = lift . string
instance (CharParsing m, Monoid w) => CharParsing (Strict.RWST r w s m) where
satisfy = lift . satisfy
char = lift . char
notChar = lift . notChar
anyChar = lift anyChar
string = lift . string
instance CharParsing m => CharParsing (IdentityT m) where
satisfy = lift . satisfy
char = lift . char
notChar = lift . notChar
anyChar = lift anyChar
string = lift . string
charLiteral' :: CharParsing m => m Char
charLiteral' = between (char '\'') (char '\'' <?> "end of character") characterChar
<?> "character"
characterChar, charEscape, charLetter :: CharParsing m => m Char
characterChar = charLetter <|> charEscape
<?> "literal character"
charEscape = char '\\' *> escapeCode
charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))
stringLiteral' :: CharParsing m => m String
stringLiteral' = Prelude.foldr (maybe id (:)) "" <$>
between (char '"') (char '"' <?> "end of string") (many stringChar) <?>
"literal string" where
stringChar = Just <$> stringLetter
<|> stringEscape
<?> "string character"
stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))
stringEscape = char '\\' *> esc where
esc = Nothing <$ escapeGap
<|> Nothing <$ escapeEmpty
<|> Just <$> escapeCode
escapeEmpty = char '&'
escapeGap = do skipSome space
char '\\' <?> "end of string gap"
escapeCode :: CharParsing m => m Char
escapeCode = (charEsc <|> charNum <|> charAscii <|> charControl) <?> "escape code"
where
charControl = (\c -> toEnum (fromEnum c fromEnum 'A')) <$> (char '^' *> upper)
charNum = toEnum . fromInteger <$> num where
num = decimal
<|> (char 'o' *> number 8 octDigit)
<|> (char 'x' *> number 16 hexDigit)
charEsc = choice $ parseEsc <$> escMap
parseEsc (c,code) = code <$ char c
escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'")
charAscii = choice $ parseAscii <$> asciiMap
parseAscii (asc,code) = try $ code <$ string asc
asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)
ascii2codes, ascii3codes :: [String]
ascii2codes = [ "BS","HT","LF","VT","FF","CR","SO"
, "SI","EM","FS","GS","RS","US","SP"]
ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK"
,"BEL","DLE","DC1","DC2","DC3","DC4","NAK"
,"SYN","ETB","CAN","SUB","ESC","DEL"]
ascii2, ascii3 :: [Char]
ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI'
,'\EM','\FS','\GS','\RS','\US','\SP']
ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK'
,'\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK'
,'\SYN','\ETB','\CAN','\SUB','\ESC','\DEL']
natural' :: CharParsing m => m Integer
natural' = nat <?> "natural"
number :: CharParsing m => Integer -> m Char -> m Integer
number base baseDigit = do
digits <- some baseDigit
return $! foldl' (\x d -> base*x + toInteger (digitToInt d)) 0 digits
integer' :: CharParsing m => m Integer
integer' = int <?> "integer"
sign :: CharParsing m => m (Integer -> Integer)
sign = negate <$ char '-'
<|> id <$ char '+'
<|> pure id
int :: CharParsing m => m Integer
int = sign <*> nat
nat, zeroNumber :: CharParsing m => m Integer
nat = zeroNumber <|> decimal
zeroNumber = char '0' *> (hexadecimal <|> octal <|> decimal <|> return 0) <?> ""
double' :: CharParsing m => m Double
double' = floating <?> "double"
floating :: CharParsing m => m Double
floating = decimal >>= fractExponent
fractExponent :: CharParsing m => Integer -> m Double
fractExponent n = (\fract expo -> (fromInteger n + fract) * expo) <$> fraction <*> option 1.0 exponent'
<|> (fromInteger n *) <$> exponent' where
fraction = Prelude.foldr op 0.0 <$> (char '.' *> (some digit <?> "fraction"))
op d f = (f + fromIntegral (digitToInt d))/10.0
exponent' = do
_ <- oneOf "eE"
f <- sign
e <- decimal <?> "exponent"
return (power (f e))
<?> "exponent"
power e
| e < 0 = 1.0/power(e)
| otherwise = fromInteger (10^e)
naturalOrDouble' :: CharParsing m => m (Either Integer Double)
naturalOrDouble' = natDouble <?> "number"
natDouble, zeroNumFloat, decimalFloat :: CharParsing m => m (Either Integer Double)
natDouble
= char '0' *> zeroNumFloat
<|> decimalFloat
zeroNumFloat
= Left <$> (hexadecimal <|> octal)
<|> decimalFloat
<|> fractFloat 0
<|> return (Left 0)
decimalFloat = do
n <- decimal
option (Left n) (fractFloat n)
fractFloat :: CharParsing m => Integer -> m (Either Integer Double)
fractFloat n = Right <$> fractExponent n
decimal :: CharParsing m => m Integer
decimal = number 10 digit
hexadecimal :: CharParsing m => m Integer
hexadecimal = oneOf "xX" *> number 16 hexDigit
octal :: CharParsing m => m Integer
octal = oneOf "oO" *> number 8 octDigit