module Text.Trifecta.Parser.Token.Prim
( charLiteral'
, characterChar
, stringLiteral'
, natural'
, integer'
, double'
, naturalOrDouble'
, decimal
, hexadecimal
, octal
) where
import Data.Char (digitToInt)
import Data.Foldable
import Control.Applicative
import Text.Trifecta.Parser.Class
import Text.Trifecta.Parser.Char
import Text.Trifecta.Parser.Combinators
import Text.Trifecta.Highlight.Prim
charLiteral' :: MonadParser m => m Char
charLiteral' = highlight CharLiteral (between (char '\'') (char '\'' <?> "end of character") characterChar)
<?> "character"
characterChar, charEscape, charLetter :: MonadParser m => m Char
characterChar = charLetter <|> charEscape
<?> "literal character"
charEscape = highlight EscapeCode $ char '\\' *> escapeCode
charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))
stringLiteral' :: MonadParser m => m String
stringLiteral' = highlight StringLiteral lit where
lit = Prelude.foldr (maybe id (:)) "" <$> between (char '"') (char '"' <?> "end of string") (many stringChar)
<?> "literal string"
stringChar = Just <$> stringLetter
<|> stringEscape
<?> "string character"
stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))
stringEscape = highlight EscapeCode $ char '\\' *> esc where
esc = Nothing <$ escapeGap
<|> Nothing <$ escapeEmpty
<|> Just <$> escapeCode
escapeEmpty = char '&'
escapeGap = do skipSome space
char '\\' <?> "end of string gap"
escapeCode :: MonadParser 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' :: MonadParser m => m Integer
natural' = highlight Number nat <?> "natural"
number :: MonadParser 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' :: MonadParser m => m Integer
integer' = int <?> "integer"
sign :: MonadParser m => m (Integer -> Integer)
sign = highlight Operator
$ negate <$ char '-'
<|> id <$ char '+'
<|> pure id
int :: MonadParser m => m Integer
int = sign <*> highlight Number nat
nat, zeroNumber :: MonadParser m => m Integer
nat = zeroNumber <|> decimal
zeroNumber = char '0' *> (hexadecimal <|> octal <|> decimal <|> return 0) <?> ""
double' :: MonadParser m => m Double
double' = highlight Number floating <?> "double"
floating :: MonadParser m => m Double
floating = decimal >>= fractExponent
fractExponent :: MonadParser 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' :: MonadParser m => m (Either Integer Double)
naturalOrDouble' = highlight Number natDouble <?> "number"
natDouble, zeroNumFloat, decimalFloat :: MonadParser 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 :: MonadParser m => Integer -> m (Either Integer Double)
fractFloat n = Right <$> fractExponent n
decimal :: MonadParser m => m Integer
decimal = number 10 digit
hexadecimal :: MonadParser m => m Integer
hexadecimal = oneOf "xX" *> number 16 hexDigit
octal :: MonadParser m => m Integer
octal = oneOf "oO" *> number 8 octDigit