module Language.Haskell.Lexer (Token(..), lexer) where
import Language.Haskell.ParseMonad
import Data.Char (chr, digitToInt, isAlpha, isDigit,
isHexDigit, isLower, isOctDigit,
isSpace, isUpper, ord, toLower)
import qualified Data.Char (isSymbol)
import Data.Ratio
data Token
= VarId String
| QVarId (String,String)
| ConId String
| QConId (String,String)
| VarSym String
| ConSym String
| QVarSym (String,String)
| QConSym (String,String)
| IntTok Integer
| FloatTok Rational
| Character Char
| StringTok String
| LeftParen
| RightParen
| SemiColon
| LeftCurly
| RightCurly
| VRightCurly
| LeftSquare
| RightSquare
| Comma
| Underscore
| BackQuote
| DotDot
| Colon
| DoubleColon
| Equals
| Backslash
| Bar
| LeftArrow
| RightArrow
| At
| Tilde
| DoubleArrow
| Minus
| Exclamation
| KW_Case
| KW_Class
| KW_Data
| KW_Default
| KW_Deriving
| KW_Do
| KW_Else
| KW_Foreign
| KW_If
| KW_Import
| KW_In
| KW_Infix
| KW_InfixL
| KW_InfixR
| KW_Instance
| KW_Let
| KW_Module
| KW_NewType
| KW_Of
| KW_Then
| KW_Type
| KW_Where
| KW_As
| KW_Export
| KW_Hiding
| KW_Qualified
| KW_Safe
| KW_Unsafe
| EOF
deriving (Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq,Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show)
reserved_ops :: [(String,Token)]
reserved_ops :: [(String, Token)]
reserved_ops = [
( "..", Token
DotDot ),
( ":", Token
Colon ),
( "::", Token
DoubleColon ),
( "=", Token
Equals ),
( "\\", Token
Backslash ),
( "|", Token
Bar ),
( "<-", Token
LeftArrow ),
( "->", Token
RightArrow ),
( "@", Token
At ),
( "~", Token
Tilde ),
( "=>", Token
DoubleArrow )
]
special_varops :: [(String,Token)]
special_varops :: [(String, Token)]
special_varops = [
( "-", Token
Minus ),
( "!", Token
Exclamation )
]
reserved_ids :: [(String,Token)]
reserved_ids :: [(String, Token)]
reserved_ids = [
( "_", Token
Underscore ),
( "case", Token
KW_Case ),
( "class", Token
KW_Class ),
( "data", Token
KW_Data ),
( "default", Token
KW_Default ),
( "deriving", Token
KW_Deriving ),
( "do", Token
KW_Do ),
( "else", Token
KW_Else ),
( "foreign", Token
KW_Foreign ),
( "if", Token
KW_If ),
( "import", Token
KW_Import ),
( "in", Token
KW_In ),
( "infix", Token
KW_Infix ),
( "infixl", Token
KW_InfixL ),
( "infixr", Token
KW_InfixR ),
( "instance", Token
KW_Instance ),
( "let", Token
KW_Let ),
( "module", Token
KW_Module ),
( "newtype", Token
KW_NewType ),
( "of", Token
KW_Of ),
( "then", Token
KW_Then ),
( "type", Token
KW_Type ),
( "where", Token
KW_Where )
]
special_varids :: [(String,Token)]
special_varids :: [(String, Token)]
special_varids = [
( "as", Token
KW_As ),
( "export", Token
KW_Export ),
( "hiding", Token
KW_Hiding ),
( "qualified", Token
KW_Qualified ),
( "safe", Token
KW_Safe ),
( "unsafe", Token
KW_Unsafe )
]
isIdent, isSymbol :: Char -> Bool
isIdent :: Char -> Bool
isIdent c :: Char
c = Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\'' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_'
isSymbol :: Char -> Bool
isSymbol c :: Char
c = Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ":!#%&*./?@\\-" Bool -> Bool -> Bool
|| (Char -> Bool
Data.Char.isSymbol Char
c Bool -> Bool -> Bool
&& Bool -> Bool
not (Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "(),;[]`{}_\"'"))
matchChar :: Char -> String -> Lex a ()
matchChar :: Char -> String -> Lex a ()
matchChar c :: Char
c msg :: String
msg = do
String
s <- Lex a String
forall r. Lex r String
getInput
if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s Bool -> Bool -> Bool
|| String -> Char
forall a. [a] -> a
head String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
c then String -> Lex a ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg else Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
lexer :: (Token -> P a) -> P a
lexer :: (Token -> P a) -> P a
lexer = Lex a Token -> (Token -> P a) -> P a
forall r a. Lex r a -> (a -> P r) -> P r
runL (Lex a Token -> (Token -> P a) -> P a)
-> Lex a Token -> (Token -> P a) -> P a
forall a b. (a -> b) -> a -> b
$ do
Bool
bol <- Lex a Bool
forall a. Lex a Bool
checkBOL
Bool
bol' <- Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
bol
Lex a ()
forall a. Lex a ()
startToken
if Bool
bol' then Lex a Token
forall a. Lex a Token
lexBOL else Lex a Token
forall a. Lex a Token
lexToken
lexWhiteSpace :: Bool -> Lex a Bool
lexWhiteSpace :: Bool -> Lex a Bool
lexWhiteSpace bol :: Bool
bol = do
String
s <- Lex a String
forall r. Lex r String
getInput
case String
s of
'{':'-':_ -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2
Bool
bol' <- Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexNestedComment Bool
bol
Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
bol'
'-':'-':rest :: String
rest | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-') ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isSymbol String
rest) -> do
String
_ <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-')
String
_ <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\n')
String
s' <- Lex a String
forall r. Lex r String
getInput
case String
s' of
[] -> String -> Lex a Bool
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Unterminated end-of-line comment"
_ -> do
Lex a ()
forall a. Lex a ()
lexNewline
Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
True
'\n':_ -> do
Lex a ()
forall a. Lex a ()
lexNewline
Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
True
'\t':_ -> do
Lex a ()
forall a. Lex a ()
lexTab
Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
bol
c :: Char
c:_ | Char -> Bool
isSpace Char
c -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
bol
_ -> Bool -> Lex a Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
bol
lexNestedComment :: Bool -> Lex a Bool
bol :: Bool
bol = do
String
s <- Lex a String
forall r. Lex r String
getInput
case String
s of
'-':'}':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Bool -> Lex a Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Lex a Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
bol
'{':'-':_ -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2
Bool
bol' <- Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexNestedComment Bool
bol
Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexNestedComment Bool
bol'
'\t':_ -> Lex a ()
forall a. Lex a ()
lexTab Lex a () -> Lex a Bool -> Lex a Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexNestedComment Bool
bol
'\n':_ -> Lex a ()
forall a. Lex a ()
lexNewline Lex a () -> Lex a Bool -> Lex a Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexNestedComment Bool
True
_:_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Bool -> Lex a Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexNestedComment Bool
bol
[] -> String -> Lex a Bool
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Unterminated nested comment"
lexBOL :: Lex a Token
lexBOL :: Lex a Token
lexBOL = do
Ordering
pos <- Lex a Ordering
forall a. Lex a Ordering
getOffside
case Ordering
pos of
LT -> do
Lex a ()
forall a. Lex a ()
setBOL
String -> Lex a ()
forall a. String -> Lex a ()
popContextL "lexBOL"
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
VRightCurly
EQ ->
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
SemiColon
GT ->
Lex a Token
forall a. Lex a Token
lexToken
lexToken :: Lex a Token
lexToken :: Lex a Token
lexToken = do
String
s <- Lex a String
forall r. Lex r String
getInput
case String
s of
[] -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
EOF
'0':c :: Char
c:d :: Char
d:_ | Char -> Char
toLower Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'o' Bool -> Bool -> Bool
&& Char -> Bool
isOctDigit Char
d -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2
Integer
n <- Lex a Integer
forall a. Lex a Integer
lexOctal
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Token
IntTok Integer
n)
| Char -> Char
toLower Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'x' Bool -> Bool -> Bool
&& Char -> Bool
isHexDigit Char
d -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2
Integer
n <- Lex a Integer
forall a. Lex a Integer
lexHexadecimal
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Token
IntTok Integer
n)
c :: Char
c:_ | Char -> Bool
isDigit Char
c -> Lex a Token
forall a. Lex a Token
lexDecimalOrFloat
| Char -> Bool
isUpper Char
c -> String -> Lex a Token
forall a. String -> Lex a Token
lexConIdOrQual ""
| Char -> Bool
isLower Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_' -> do
String
ident <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ case String -> [(String, Token)] -> Maybe Token
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
ident ([(String, Token)]
reserved_ids [(String, Token)] -> [(String, Token)] -> [(String, Token)]
forall a. [a] -> [a] -> [a]
++ [(String, Token)]
special_varids) of
Just keyword :: Token
keyword -> Token
keyword
Nothing -> String -> Token
VarId String
ident
| Char -> Bool
isSymbol Char
c -> do
String
sym <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isSymbol
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ case String -> [(String, Token)] -> Maybe Token
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
sym ([(String, Token)]
reserved_ops [(String, Token)] -> [(String, Token)] -> [(String, Token)]
forall a. [a] -> [a] -> [a]
++ [(String, Token)]
special_varops) of
Just t :: Token
t -> Token
t
Nothing -> case Char
c of
':' -> String -> Token
ConSym String
sym
_ -> String -> Token
VarSym String
sym
| Bool
otherwise -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
case Char
c of
'(' -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
LeftParen
')' -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RightParen
',' -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
Comma
';' -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
SemiColon
'[' -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
LeftSquare
']' -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RightSquare
'`' -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
BackQuote
'{' -> do
LexContext -> Lex a ()
forall a. LexContext -> Lex a ()
pushContextL LexContext
NoLayout
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
LeftCurly
'}' -> do
String -> Lex a ()
forall a. String -> Lex a ()
popContextL "lexToken"
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RightCurly
'\'' -> do
Char
c2 <- Lex a Char
forall a. Lex a Char
lexChar
Char -> String -> Lex a ()
forall a. Char -> String -> Lex a ()
matchChar '\'' "Improperly terminated character constant"
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Token
Character Char
c2)
'"' -> Lex a Token
forall a. Lex a Token
lexString
_ -> String -> Lex a Token
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("Illegal character \'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\'\n")
lexDecimalOrFloat :: Lex a Token
lexDecimalOrFloat :: Lex a Token
lexDecimalOrFloat = do
String
ds <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isDigit
String
rest <- Lex a String
forall r. Lex r String
getInput
case String
rest of
('.':d :: Char
d:_) | Char -> Bool
isDigit Char
d -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
String
frac <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isDigit
let num :: Integer
num = Integer -> String -> Integer
parseInteger 10 (String
ds String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
frac)
decimals :: Integer
decimals = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
frac)
Integer
exponent' <- do
String
rest2 <- Lex a String
forall r. Lex r String
getInput
case String
rest2 of
'e':_ -> Lex a Integer
forall a. Lex a Integer
lexExponent
'E':_ -> Lex a Integer
forall a. Lex a Integer
lexExponent
_ -> Integer -> Lex a Integer
forall (m :: * -> *) a. Monad m => a -> m a
return 0
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Rational -> Token
FloatTok ((Integer
numInteger -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%1) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* 10Rational -> Integer -> Rational
forall a b. (Fractional a, Integral b) => a -> b -> a
^^(Integer
exponent' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
decimals)))
e :: Char
e:_ | Char -> Char
toLower Char
e Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'e' -> do
Integer
exponent' <- Lex a Integer
forall a. Lex a Integer
lexExponent
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Rational -> Token
FloatTok ((Integer -> String -> Integer
parseInteger 10 String
dsInteger -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%1) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* 10Rational -> Integer -> Rational
forall a b. (Fractional a, Integral b) => a -> b -> a
^^Integer
exponent'))
_ -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Token
IntTok (Integer -> String -> Integer
parseInteger 10 String
ds))
where
lexExponent :: Lex a Integer
lexExponent :: Lex a Integer
lexExponent = do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
String
r <- Lex a String
forall r. Lex r String
getInput
case String
r of
'+':d :: Char
d:_ | Char -> Bool
isDigit Char
d -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
Lex a Integer
forall a. Lex a Integer
lexDecimal
'-':d :: Char
d:_ | Char -> Bool
isDigit Char
d -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
Integer
n <- Lex a Integer
forall a. Lex a Integer
lexDecimal
Integer -> Lex a Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Integer
forall a. Num a => a -> a
negate Integer
n)
d :: Char
d:_ | Char -> Bool
isDigit Char
d -> Lex a Integer
forall a. Lex a Integer
lexDecimal
_ -> String -> Lex a Integer
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Float with missing exponent"
lexConIdOrQual :: String -> Lex a Token
lexConIdOrQual :: String -> Lex a Token
lexConIdOrQual qual :: String
qual = do
String
con <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
let conid :: Token
conid | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
qual = String -> Token
ConId String
con
| Bool
otherwise = (String, String) -> Token
QConId (String
qual,String
con)
qual' :: String
qual' | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
qual = String
con
| Bool
otherwise = String
qual String -> ShowS
forall a. [a] -> [a] -> [a]
++ '.'Char -> ShowS
forall a. a -> [a] -> [a]
:String
con
Lex a Token
just_a_conid <- Lex a Token -> Lex a (Lex a Token)
forall a v. Lex a v -> Lex a (Lex a v)
alternative (Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
conid)
String
rest <- Lex a String
forall r. Lex r String
getInput
case String
rest of
'.':c :: Char
c:_
| Char -> Bool
isLower Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_' -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
String
ident <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
case String -> [(String, Token)] -> Maybe Token
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
ident [(String, Token)]
reserved_ids of
Just _ -> Lex a Token
just_a_conid
Nothing -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> Token
QVarId (String
qual', String
ident))
| Char -> Bool
isUpper Char
c -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
String -> Lex a Token
forall a. String -> Lex a Token
lexConIdOrQual String
qual'
| Char -> Bool
isSymbol Char
c -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
String
sym <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isSymbol
case String -> [(String, Token)] -> Maybe Token
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
sym [(String, Token)]
reserved_ops of
Just _ -> Lex a Token
just_a_conid
Nothing -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ case Char
c of
':' -> (String, String) -> Token
QConSym (String
qual', String
sym)
_ -> (String, String) -> Token
QVarSym (String
qual', String
sym)
_ -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
conid
lexChar :: Lex a Char
lexChar :: Lex a Char
lexChar = do
String
r <- Lex a String
forall r. Lex r String
getInput
case String
r of
'\\':_ -> Lex a Char
forall a. Lex a Char
lexEscape
c :: Char
c:_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c
[] -> String -> Lex a Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Incomplete character constant"
lexString :: Lex a Token
lexString :: Lex a Token
lexString = String -> Lex a Token
forall a. String -> Lex a Token
loop ""
where
loop :: String -> Lex r Token
loop s :: String
s = do
String
r <- Lex r String
forall r. Lex r String
getInput
case String
r of
'\\':'&':_ -> do
Int -> Lex r ()
forall r. Int -> Lex r ()
discard 2
String -> Lex r Token
loop String
s
'\\':c :: Char
c:_ | Char -> Bool
isSpace Char
c -> do
Int -> Lex r ()
forall r. Int -> Lex r ()
discard 1
Lex r ()
forall a. Lex a ()
lexWhiteChars
Char -> String -> Lex r ()
forall a. Char -> String -> Lex a ()
matchChar '\\' "Illegal character in string gap"
String -> Lex r Token
loop String
s
| Bool
otherwise -> do
Char
ce <- Lex r Char
forall a. Lex a Char
lexEscape
String -> Lex r Token
loop (Char
ceChar -> ShowS
forall a. a -> [a] -> [a]
:String
s)
'"':_ -> do
Int -> Lex r ()
forall r. Int -> Lex r ()
discard 1
Token -> Lex r Token
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Token
StringTok (ShowS
forall a. [a] -> [a]
reverse String
s))
c :: Char
c:_ -> do
Int -> Lex r ()
forall r. Int -> Lex r ()
discard 1
String -> Lex r Token
loop (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
s)
[] -> String -> Lex r Token
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Improperly terminated string"
lexWhiteChars :: Lex a ()
lexWhiteChars :: Lex a ()
lexWhiteChars = do
String
s <- Lex a String
forall r. Lex r String
getInput
case String
s of
'\n':_ -> do
Lex a ()
forall a. Lex a ()
lexNewline
Lex a ()
forall a. Lex a ()
lexWhiteChars
'\t':_ -> do
Lex a ()
forall a. Lex a ()
lexTab
Lex a ()
forall a. Lex a ()
lexWhiteChars
c :: Char
c:_ | Char -> Bool
isSpace Char
c -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
Lex a ()
forall a. Lex a ()
lexWhiteChars
_ -> () -> Lex a ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
lexEscape :: Lex a Char
lexEscape :: Lex a Char
lexEscape = do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
String
r <- Lex a String
forall r. Lex r String
getInput
case String
r of
'a':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\a'
'b':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\b'
'f':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\f'
'n':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\n'
'r':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\r'
't':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\t'
'v':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\v'
'\\':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\\'
'"':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\"'
'\'':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\''
'^':c :: Char
c:_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. Char -> Lex a Char
cntrl Char
c
'N':'U':'L':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\NUL'
'S':'O':'H':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\SOH'
'S':'T':'X':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\STX'
'E':'T':'X':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\ETX'
'E':'O':'T':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\EOT'
'E':'N':'Q':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\ENQ'
'A':'C':'K':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\ACK'
'B':'E':'L':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\BEL'
'B':'S':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\BS'
'H':'T':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\HT'
'L':'F':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\LF'
'V':'T':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\VT'
'F':'F':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\FF'
'C':'R':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\CR'
'S':'O':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\SO'
'S':'I':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\SI'
'D':'L':'E':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\DLE'
'D':'C':'1':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\DC1'
'D':'C':'2':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\DC2'
'D':'C':'3':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\DC3'
'D':'C':'4':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\DC4'
'N':'A':'K':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\NAK'
'S':'Y':'N':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\SYN'
'E':'T':'B':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\ETB'
'C':'A':'N':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\CAN'
'E':'M':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\EM'
'S':'U':'B':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\SUB'
'E':'S':'C':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\ESC'
'F':'S':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\FS'
'G':'S':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\GS'
'R':'S':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\RS'
'U':'S':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\US'
'S':'P':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\SP'
'D':'E':'L':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\DEL'
'o':c :: Char
c:_ | Char -> Bool
isOctDigit Char
c -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
Integer
n <- Lex a Integer
forall a. Lex a Integer
lexOctal
Integer -> Lex a Char
forall (m :: * -> *). MonadFail m => Integer -> m Char
checkChar Integer
n
'x':c :: Char
c:_ | Char -> Bool
isHexDigit Char
c -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
Integer
n <- Lex a Integer
forall a. Lex a Integer
lexHexadecimal
Integer -> Lex a Char
forall (m :: * -> *). MonadFail m => Integer -> m Char
checkChar Integer
n
c :: Char
c:_ | Char -> Bool
isDigit Char
c -> do
Integer
n <- Lex a Integer
forall a. Lex a Integer
lexDecimal
Integer -> Lex a Char
forall (m :: * -> *). MonadFail m => Integer -> m Char
checkChar Integer
n
_ -> String -> Lex a Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Illegal escape sequence"
where
checkChar :: Integer -> m Char
checkChar n :: Integer
n | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x10FFFF = Char -> m Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n))
checkChar _ = String -> m Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Character constant out of range"
cntrl :: Char -> Lex a Char
cntrl :: Char -> Lex a Char
cntrl c :: Char
c | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '@' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '_' = Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord '@'))
cntrl _ = String -> Lex a Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Illegal control character"
lexOctal :: Lex a Integer
lexOctal :: Lex a Integer
lexOctal = do
String
ds <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isOctDigit
Integer -> Lex a Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> String -> Integer
parseInteger 8 String
ds)
lexHexadecimal :: Lex a Integer
lexHexadecimal :: Lex a Integer
lexHexadecimal = do
String
ds <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isHexDigit
Integer -> Lex a Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> String -> Integer
parseInteger 16 String
ds)
lexDecimal :: Lex a Integer
lexDecimal :: Lex a Integer
lexDecimal = do
String
ds <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isDigit
Integer -> Lex a Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> String -> Integer
parseInteger 10 String
ds)
parseInteger :: Integer -> String -> Integer
parseInteger :: Integer -> String -> Integer
parseInteger radix :: Integer
radix ds :: String
ds =
(Integer -> Integer -> Integer) -> [Integer] -> Integer
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\n :: Integer
n d :: Integer
d -> Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
radix Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
d) ((Char -> Integer) -> String -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> (Char -> Int) -> Char -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
digitToInt) String
ds)