-----------------------------------------------------------------------------
-- |
-- 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
$c== :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
/= :: 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
$cshowsPrec :: Int -> Token -> ShowS
showsPrec :: Int -> Token -> ShowS
$cshow :: Token -> String
show :: Token -> String
$cshowList :: [Token] -> ShowS
showList :: [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 a. Eq a => a -> [a] -> 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 a. Eq a => a -> [a] -> 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
  s <- Lex a String
forall r. Lex r String
getInput
  case s of
    Char
c':String
_ | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c' -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
    String
_ -> String -> Lex a ()
forall a. String -> Lex a a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg

-- 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
        bol  <- Lex a Bool
forall a. Lex a Bool
checkBOL
        bol' <- lexWhiteSpace bol
        startToken
        if bol' then lexBOL else lexToken

lexWhiteSpace :: Bool -> Lex a Bool
lexWhiteSpace :: forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
bol = do
        s <- Lex a String
forall r. Lex r String
getInput
        case s of
            Char
'{':Char
'-':String
_ -> do
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
                bol' <- Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexNestedComment Bool
bol
                lexWhiteSpace 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
                _ <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')
                _ <- lexWhile (/= '\n')
                s' <- getInput
                case s' of
                    [] -> String -> Lex a Bool
forall a. String -> Lex a a
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 a. a -> Lex a a
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
        s <- Lex a String
forall r. Lex r String
getInput
        case 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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Lex a Bool
forall a. a -> Lex a a
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
                bol' <- Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexNestedComment Bool
bol    -- rest of the subcomment
                lexNestedComment bol'           -- rest of this comment
            Char
'\t':String
_    -> Lex a ()
forall a. Lex a ()
lexTab Lex a () -> Lex a Bool -> Lex a Bool
forall a b. Lex a a -> Lex a b -> Lex a b
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 a b. Lex a a -> Lex a b -> Lex a b
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 a b. Lex a a -> Lex a b -> Lex a b
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 a. String -> Lex a a
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
        pos <- Lex a Ordering
forall a. Lex a Ordering
getOffside
        case 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 a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Token
VRightCurly
            Ordering
EQ ->
                -- trace "layout: inserting ';'\n" $
                Token -> Lex a Token
forall a. a -> Lex a a
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
    s <- Lex a String
forall r. Lex r String
getInput
    case s of
        [] -> Token -> Lex a Token
forall a. a -> Lex a a
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
                        n <- Lex a Integer
forall a. Lex a Integer
lexOctal
                        return (IntTok 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
                        n <- Lex a Integer
forall a. Lex a Integer
lexHexadecimal
                        return (IntTok 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
                ident <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
                return $ case lookup ident (reserved_ids ++ special_varids) of
                        Just Token
keyword -> Token
keyword
                        Maybe Token
Nothing      -> String -> Token
VarId String
ident

            | Char -> Bool
isSymbol Char
c -> do
                sym <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isSymbol
                return $ case lookup sym (reserved_ops ++ 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 a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Token
LeftParen
                    Char
')' ->  Token -> Lex a Token
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RightParen
                    Char
',' ->  Token -> Lex a Token
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Token
Comma
                    Char
';' ->  Token -> Lex a Token
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Token
SemiColon
                    Char
'[' ->  Token -> Lex a Token
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Token
LeftSquare
                    Char
']' ->  Token -> Lex a Token
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RightSquare
                    Char
'`' ->  Token -> Lex a Token
forall a. a -> Lex a a
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 a. a -> Lex a a
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 a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RightCurly

                    Char
'\'' -> do
                            c2 <- Lex a Char
forall a. Lex a Char
lexChar
                            matchChar '\'' "Improperly terminated character constant"
                            return (Character c2)

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

                    Char
_ ->    String -> Lex a Token
forall a. String -> Lex a a
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
        ds <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isDigit
        rest <- getInput
        case rest of
            (Char
'.':Char
d:String
_) | Char -> Bool
isDigit Char
d -> do
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
                frac <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isDigit
                let num = Integer -> String -> Integer
parseInteger Integer
10 (String
ds String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
frac)
                    decimals = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
frac)
                exponent' <- do
                        rest2 <- getInput
                        case 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 a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0
                return (FloatTok ((num%1) * 10^^(exponent' - decimals)))
            Char
e:String
_ | Char -> Char
toLower Char
e Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'e' -> do
                exponent' <- Lex a Integer
forall a. Lex a Integer
lexExponent
                return (FloatTok ((parseInteger 10 ds%1) * 10^^exponent'))
            String
_ -> Token -> Lex a Token
forall a. a -> Lex a a
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'
                r <- Lex a String
forall r. Lex r String
getInput
                case 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
                        n <- Lex a Integer
forall a. Lex a Integer
lexDecimal
                        return (negate n)
                    Char
d:String
_ | Char -> Bool
isDigit Char
d -> Lex a Integer
forall a. Lex a Integer
lexDecimal
                    String
_ -> String -> Lex a Integer
forall a. String -> Lex a a
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
        con <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
        let conid | String -> Bool
forall a. [a] -> 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 -> Bool
forall a. [a] -> 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
        just_a_conid <- alternative (return conid)
        rest <- getInput
        case 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
                ident <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
                case lookup ident reserved_ids of
                   -- cannot qualify a reserved word
                   Just Token
_  -> Lex a Token
just_a_conid
                   Maybe Token
Nothing -> Token -> Lex a Token
forall a. a -> Lex a a
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
                sym <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isSymbol
                case lookup sym reserved_ops of
                    -- cannot qualify a reserved operator
                    Just Token
_  -> Lex a Token
just_a_conid
                    Maybe Token
Nothing -> Token -> Lex a Token
forall a. a -> Lex a a
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 a. a -> Lex a a
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
        r <- Lex a String
forall r. Lex r String
getInput
        case 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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c
                []     -> String -> Lex a Char
forall a. String -> Lex a a
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
                r <- Lex r String
forall r. Lex r String
getInput
                case 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
                                ce <- Lex r Char
forall a. Lex a Char
lexEscape
                                loop (ce:s)
                    Char
'"':String
_ -> do
                                Int -> Lex r ()
forall r. Int -> Lex r ()
discard Int
1
                                Token -> Lex r Token
forall a. a -> Lex r a
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 a. String -> Lex r a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Improperly terminated string"

        lexWhiteChars :: Lex a ()
        lexWhiteChars :: forall a. Lex a ()
lexWhiteChars = do
                s <- Lex a String
forall r. Lex r String
getInput
                case 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 a. a -> Lex a 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
        r <- Lex a String
forall r. Lex r String
getInput
        case 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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall a. a -> Lex a a
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
                                        n <- Lex a Integer
forall a. Lex a Integer
lexOctal
                                        checkChar n
                Char
'x':Char
c:String
_ | Char -> Bool
isHexDigit Char
c -> do
                                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
                                        n <- Lex a Integer
forall a. Lex a Integer
lexHexadecimal
                                        checkChar n
                Char
c:String
_ | Char -> Bool
isDigit Char
c -> do
                                        n <- Lex a Integer
forall a. Lex a Integer
lexDecimal
                                        checkChar n

                String
_               -> String -> Lex a Char
forall a. String -> Lex a a
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 a. a -> m a
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 a. String -> m a
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 a. a -> Lex a a
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 a. String -> Lex a a
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
        ds <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isOctDigit
        return (parseInteger 8 ds)

-- assumes at least one hexadecimal digit
lexHexadecimal :: Lex a Integer
lexHexadecimal :: forall a. Lex a Integer
lexHexadecimal = do
        ds <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isHexDigit
        return (parseInteger 16 ds)

-- assumes at least one decimal digit
lexDecimal :: Lex a Integer
lexDecimal :: forall a. Lex a Integer
lexDecimal = do
        ds <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isDigit
        return (parseInteger 10 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 a. (a -> a -> a) -> [a] -> a
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)