-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.Lexer
-- Copyright   :  (c) The GHC Team, 1997-2000
-- License     :  BSD-3-Clause
--
-- Maintainer  :  Andreas Abel
-- Stability   :  stable
-- Portability :  portable
--
-- Lexer for Haskell.
--
-----------------------------------------------------------------------------

-- ToDo: Introduce different tokens for decimal, octal and hexadecimal (?)
-- ToDo: FloatTok should have three parts (integer part, fraction, exponent) (?)
-- ToDo: Use a lexical analyser generator (lx?)

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

-- Symbols

        | LeftParen
        | RightParen
        | SemiColon
        | LeftCurly
        | RightCurly
        | VRightCurly                   -- a virtual close brace
        | LeftSquare
        | RightSquare
        | Comma
        | Underscore
        | BackQuote

-- Reserved operators

        | DotDot
        | Colon
        | DoubleColon
        | Equals
        | Backslash
        | Bar
        | LeftArrow
        | RightArrow
        | At
        | Tilde
        | DoubleArrow
        | Minus
        | Exclamation

-- Reserved Ids

        | 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

-- Special Ids

        | 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 = [
 ( String
"..", Token
DotDot ),
 ( String
":",  Token
Colon ),
 ( String
"::", Token
DoubleColon ),
 ( String
"=",  Token
Equals ),
 ( String
"\\", Token
Backslash ),
 ( String
"|",  Token
Bar ),
 ( String
"<-", Token
LeftArrow ),
 ( String
"->", Token
RightArrow ),
 ( String
"@",  Token
At ),
 ( String
"~",  Token
Tilde ),
 ( String
"=>", Token
DoubleArrow )
 ]

special_varops :: [(String,Token)]
special_varops :: [(String, Token)]
special_varops = [
 ( String
"-",  Token
Minus ),                       --ToDo: shouldn't be here
 ( String
"!",  Token
Exclamation )          --ditto
 ]

reserved_ids :: [(String,Token)]
reserved_ids :: [(String, Token)]
reserved_ids = [
 ( String
"_",         Token
Underscore ),
 ( String
"case",      Token
KW_Case ),
 ( String
"class",     Token
KW_Class ),
 ( String
"data",      Token
KW_Data ),
 ( String
"default",   Token
KW_Default ),
 ( String
"deriving",  Token
KW_Deriving ),
 ( String
"do",        Token
KW_Do ),
 ( String
"else",      Token
KW_Else ),
 ( String
"foreign",   Token
KW_Foreign ),
 ( String
"if",        Token
KW_If ),
 ( String
"import",    Token
KW_Import ),
 ( String
"in",        Token
KW_In ),
 ( String
"infix",     Token
KW_Infix ),
 ( String
"infixl",    Token
KW_InfixL ),
 ( String
"infixr",    Token
KW_InfixR ),
 ( String
"instance",  Token
KW_Instance ),
 ( String
"let",       Token
KW_Let ),
 ( String
"module",    Token
KW_Module ),
 ( String
"newtype",   Token
KW_NewType ),
 ( String
"of",        Token
KW_Of ),
 ( String
"then",      Token
KW_Then ),
 ( String
"type",      Token
KW_Type ),
 ( String
"where",     Token
KW_Where )
 ]

special_varids :: [(String,Token)]
special_varids :: [(String, Token)]
special_varids = [
 ( String
"as",        Token
KW_As ),
 ( String
"export",    Token
KW_Export ),
 ( String
"hiding",    Token
KW_Hiding ),
 ( String
"qualified", Token
KW_Qualified ),
 ( String
"safe",      Token
KW_Safe ),
 ( String
"unsafe",    Token
KW_Unsafe )
 ]

isIdent, isSymbol :: Char -> Bool
isIdent :: Char -> Bool
isIdent  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
== Char
'\'' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
isSymbol :: Char -> Bool
isSymbol Char
c = Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
":!#%&*./?@\\-" 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` String
"(),;[]`{}_\"'"))

matchChar :: Char -> String -> Lex a ()
matchChar :: forall a. Char -> String -> Lex a ()
matchChar Char
c 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 Int
1

-- The top-level lexer.
-- We need to know whether we are at the beginning of the line to decide
-- whether to insert layout tokens.

lexer :: (Token -> P a) -> P a
lexer :: forall a. (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 :: forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
bol = do
        String
s <- Lex a String
forall r. Lex r String
getInput
        case String
s of
            Char
'{':Char
'-':String
_ -> do
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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'
            Char
'-':Char
'-':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
'-') ((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
== Char
'-')
                String
_ <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\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 String
"Unterminated end-of-line comment"
                    String
_ -> do
                        Lex a ()
forall a. Lex a ()
lexNewline
                        Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
True
            Char
'\n':String
_ -> do
                Lex a ()
forall a. Lex a ()
lexNewline
                Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
True
            Char
'\t':String
_ -> do
                Lex a ()
forall a. Lex a ()
lexTab
                Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
bol
            Char
c:String
_ | Char -> Bool
isSpace Char
c -> do
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
                Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
bol
            String
_ -> Bool -> Lex a Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
bol

lexNestedComment :: Bool -> Lex a Bool
lexNestedComment :: forall a. Bool -> Lex a Bool
lexNestedComment Bool
bol = do
        String
s <- Lex a String
forall r. Lex r String
getInput
        case String
s of
            Char
'-':Char
'}':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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
            Char
'{':Char
'-':String
_ -> do
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
                Bool
bol' <- Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexNestedComment Bool
bol    -- rest of the subcomment
                Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexNestedComment Bool
bol'           -- rest of this comment
            Char
'\t':String
_    -> 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
            Char
'\n':String
_    -> 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
            Char
_:String
_       -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 String
"Unterminated nested comment"

-- When we are lexing the first token of a line, check whether we need to
-- insert virtual semicolons or close braces due to layout.

lexBOL :: Lex a Token
lexBOL :: forall a. Lex a Token
lexBOL = do
        Ordering
pos <- Lex a Ordering
forall a. Lex a Ordering
getOffside
        case Ordering
pos of
            Ordering
LT -> do
                -- trace "layout: inserting '}'\n" $
                -- Set col to 0, indicating that we're still at the
                -- beginning of the line, in case we need a semi-colon too.
                -- Also pop the context here, so that we don't insert
                -- another close brace before the parser can pop it.
                Lex a ()
forall a. Lex a ()
setBOL
                String -> Lex a ()
forall a. String -> Lex a ()
popContextL String
"lexBOL"
                Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
VRightCurly
            Ordering
EQ ->
                -- trace "layout: inserting ';'\n" $
                Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
SemiColon
            Ordering
GT ->
                Lex a Token
forall a. Lex a Token
lexToken

lexToken :: Lex a Token
lexToken :: forall a. 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

        Char
'0':Char
c:Char
d:String
_ | Char -> Char
toLower Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'o' Bool -> Bool -> Bool
&& Char -> Bool
isOctDigit Char
d -> do
                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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
== Char
'x' Bool -> Bool -> Bool
&& Char -> Bool
isHexDigit Char
d -> do
                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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)

        Char
c:String
_ | 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 String
""

            | Char -> Bool
isLower Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' -> 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 Token
keyword -> Token
keyword
                        Maybe Token
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 Token
t  -> Token
t
                        Maybe Token
Nothing -> case Char
c of
                            Char
':' -> String -> Token
ConSym String
sym
                            Char
_   -> String -> Token
VarSym String
sym

            | Bool
otherwise -> do
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
                case Char
c of

                    -- First the special symbols
                    Char
'(' ->  Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
LeftParen
                    Char
')' ->  Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RightParen
                    Char
',' ->  Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
Comma
                    Char
';' ->  Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
SemiColon
                    Char
'[' ->  Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
LeftSquare
                    Char
']' ->  Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RightSquare
                    Char
'`' ->  Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
BackQuote
                    Char
'{' -> 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
                    Char
'}' -> do
                            String -> Lex a ()
forall a. String -> Lex a ()
popContextL String
"lexToken"
                            Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RightCurly

                    Char
'\'' -> do
                            Char
c2 <- Lex a Char
forall a. Lex a Char
lexChar
                            Char -> String -> Lex a ()
forall a. Char -> String -> Lex a ()
matchChar Char
'\'' String
"Improperly terminated character constant"
                            Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> Token
Character Char
c2)

                    Char
'"' ->  Lex a Token
forall a. Lex a Token
lexString

                    Char
_ ->    String -> Lex a Token
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"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]
++ String
"\'\n")

lexDecimalOrFloat :: Lex a Token
lexDecimalOrFloat :: forall a. 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
            (Char
'.':Char
d:String
_) | Char -> Bool
isDigit Char
d -> do
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Integer
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
                            Char
'e':String
_ -> Lex a Integer
forall a. Lex a Integer
lexExponent
                            Char
'E':String
_ -> Lex a Integer
forall a. Lex a Integer
lexExponent
                            String
_     -> Integer -> Lex a Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
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
%Integer
1) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
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)))
            Char
e:String
_ | Char -> Char
toLower Char
e Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'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 Integer
10 String
dsInteger -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
1) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
10Rational -> Integer -> Rational
forall a b. (Fractional a, Integral b) => a -> b -> a
^^Integer
exponent'))
            String
_ -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Token
IntTok (Integer -> String -> Integer
parseInteger Integer
10 String
ds))

    where
        lexExponent :: Lex a Integer
        lexExponent :: forall a. Lex a Integer
lexExponent = do
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1       -- 'e' or 'E'
                String
r <- Lex a String
forall r. Lex r String
getInput
                case String
r of
                    Char
'+':Char
d:String
_ | Char -> Bool
isDigit Char
d -> do
                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
                        Lex a Integer
forall a. Lex a Integer
lexDecimal
                    Char
'-':Char
d:String
_ | Char -> Bool
isDigit Char
d -> do
                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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)
                    Char
d:String
_ | Char -> Bool
isDigit Char
d -> Lex a Integer
forall a. Lex a Integer
lexDecimal
                    String
_ -> String -> Lex a Integer
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Float with missing exponent"

lexConIdOrQual :: String -> Lex a Token
lexConIdOrQual :: forall a. String -> Lex a Token
lexConIdOrQual 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
'.'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
          Char
'.':Char
c:String
_
             | Char -> Bool
isLower Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' -> do      -- qualified varid?
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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
                   -- cannot qualify a reserved word
                   Just Token
_  -> Lex a Token
just_a_conid
                   Maybe Token
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          -- qualified conid?
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
                String -> Lex a Token
forall a. String -> Lex a Token
lexConIdOrQual String
qual'

             | Char -> Bool
isSymbol Char
c -> do -- qualified symbol?
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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
                    -- cannot qualify a reserved operator
                    Just Token
_  -> Lex a Token
just_a_conid
                    Maybe Token
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
                        Char
':' -> (String, String) -> Token
QConSym (String
qual', String
sym)
                        Char
_   -> (String, String) -> Token
QVarSym (String
qual', String
sym)

          String
_ ->  Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
conid -- not a qualified thing

lexChar :: Lex a Char
lexChar :: forall a. Lex a Char
lexChar = do
        String
r <- Lex a String
forall r. Lex r String
getInput
        case String
r of
                Char
'\\':String
_ -> Lex a Char
forall a. Lex a Char
lexEscape
                Char
c:String
_    -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 String
"Incomplete character constant"

lexString :: Lex a Token
lexString :: forall a. Lex a Token
lexString = String -> Lex a Token
forall a. String -> Lex a Token
loop String
""
    where
        loop :: String -> Lex r Token
loop String
s = do
                String
r <- Lex r String
forall r. Lex r String
getInput
                case String
r of
                    Char
'\\':Char
'&':String
_ -> do
                                Int -> Lex r ()
forall r. Int -> Lex r ()
discard Int
2
                                String -> Lex r Token
loop String
s
                    Char
'\\':Char
c:String
_ | Char -> Bool
isSpace Char
c -> do
                                Int -> Lex r ()
forall r. Int -> Lex r ()
discard Int
1
                                Lex r ()
forall a. Lex a ()
lexWhiteChars
                                Char -> String -> Lex r ()
forall a. Char -> String -> Lex a ()
matchChar Char
'\\' String
"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)
                    Char
'"':String
_ -> do
                                Int -> Lex r ()
forall r. Int -> Lex r ()
discard Int
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))
                    Char
c:String
_ -> do
                                Int -> Lex r ()
forall r. Int -> Lex r ()
discard Int
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 String
"Improperly terminated string"

        lexWhiteChars :: Lex a ()
        lexWhiteChars :: forall a. Lex a ()
lexWhiteChars = do
                String
s <- Lex a String
forall r. Lex r String
getInput
                case String
s of
                    Char
'\n':String
_ -> do
                        Lex a ()
forall a. Lex a ()
lexNewline
                        Lex a ()
forall a. Lex a ()
lexWhiteChars
                    Char
'\t':String
_ -> do
                        Lex a ()
forall a. Lex a ()
lexTab
                        Lex a ()
forall a. Lex a ()
lexWhiteChars
                    Char
c:String
_ | Char -> Bool
isSpace Char
c -> do
                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
                        Lex a ()
forall a. Lex a ()
lexWhiteChars
                    String
_ -> () -> Lex a ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

lexEscape :: Lex a Char
lexEscape :: forall a. Lex a Char
lexEscape = do
        Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
        String
r <- Lex a String
forall r. Lex r String
getInput
        case String
r of

-- Production charesc from section B.2 (Note: \& is handled by caller)

                Char
'a':String
_           -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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
'\a'
                Char
'b':String
_           -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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
'\b'
                Char
'f':String
_           -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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
'\f'
                Char
'n':String
_           -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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
'\n'
                Char
'r':String
_           -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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
'\r'
                Char
't':String
_           -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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
'\t'
                Char
'v':String
_           -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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
'\v'
                Char
'\\':String
_          -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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
'\\'
                Char
'"':String
_           -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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
'\"'
                Char
'\'':String
_          -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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
'\''

-- Production ascii from section B.2

                Char
'^':Char
c:String
_         -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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
                Char
'N':Char
'U':Char
'L':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\NUL'
                Char
'S':Char
'O':Char
'H':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\SOH'
                Char
'S':Char
'T':Char
'X':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\STX'
                Char
'E':Char
'T':Char
'X':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\ETX'
                Char
'E':Char
'O':Char
'T':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\EOT'
                Char
'E':Char
'N':Char
'Q':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\ENQ'
                Char
'A':Char
'C':Char
'K':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\ACK'
                Char
'B':Char
'E':Char
'L':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\BEL'
                Char
'B':Char
'S':String
_       -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\BS'
                Char
'H':Char
'T':String
_       -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\HT'
                Char
'L':Char
'F':String
_       -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\LF'
                Char
'V':Char
'T':String
_       -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\VT'
                Char
'F':Char
'F':String
_       -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\FF'
                Char
'C':Char
'R':String
_       -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\CR'
                Char
'S':Char
'O':String
_       -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\SO'
                Char
'S':Char
'I':String
_       -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\SI'
                Char
'D':Char
'L':Char
'E':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\DLE'
                Char
'D':Char
'C':Char
'1':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\DC1'
                Char
'D':Char
'C':Char
'2':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\DC2'
                Char
'D':Char
'C':Char
'3':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\DC3'
                Char
'D':Char
'C':Char
'4':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\DC4'
                Char
'N':Char
'A':Char
'K':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\NAK'
                Char
'S':Char
'Y':Char
'N':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\SYN'
                Char
'E':Char
'T':Char
'B':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\ETB'
                Char
'C':Char
'A':Char
'N':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\CAN'
                Char
'E':Char
'M':String
_       -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\EM'
                Char
'S':Char
'U':Char
'B':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\SUB'
                Char
'E':Char
'S':Char
'C':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\ESC'
                Char
'F':Char
'S':String
_       -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\FS'
                Char
'G':Char
'S':String
_       -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\GS'
                Char
'R':Char
'S':String
_       -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\RS'
                Char
'U':Char
'S':String
_       -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\US'
                Char
'S':Char
'P':String
_       -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\SP'
                Char
'D':Char
'E':Char
'L':String
_   -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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 Char
'\DEL'

-- Escaped numbers

                Char
'o':Char
c:String
_ | Char -> Bool
isOctDigit Char
c -> do
                                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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
                Char
'x':Char
c:String
_ | Char -> Bool
isHexDigit Char
c -> do
                                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
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
                Char
c:String
_ | 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
_               -> String -> Lex a Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal escape sequence"

    where
        checkChar :: Integer -> m Char
checkChar Integer
n | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
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 Integer
_ = String -> m Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Character constant out of range"

-- Production cntrl from section B.2

        cntrl :: Char -> Lex a Char
        cntrl :: forall a. Char -> Lex a Char
cntrl Char
c | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'@' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'_' = 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 Char
'@'))
        cntrl Char
_ = String -> Lex a Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal control character"

-- assumes at least one octal digit
lexOctal :: Lex a Integer
lexOctal :: forall a. 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 Integer
8 String
ds)

-- assumes at least one hexadecimal digit
lexHexadecimal :: Lex a Integer
lexHexadecimal :: forall a. 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 Integer
16 String
ds)

-- assumes at least one decimal digit
lexDecimal :: Lex a Integer
lexDecimal :: forall a. 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 Integer
10 String
ds)

-- Stolen from Hugs's Prelude
parseInteger :: Integer -> String -> Integer
parseInteger :: Integer -> String -> Integer
parseInteger Integer
radix String
ds =
        (Integer -> Integer -> Integer) -> [Integer] -> Integer
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Integer
n 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)