-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.Lexer
-- Copyright   :  (c) The GHC Team, 1997-2000
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- 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 = [
 ( "..", Token
DotDot ),
 ( ":",  Token
Colon ),
 ( "::", Token
DoubleColon ),
 ( "=",  Token
Equals ),
 ( "\\", Token
Backslash ),
 ( "|",  Token
Bar ),
 ( "<-", Token
LeftArrow ),
 ( "->", Token
RightArrow ),
 ( "@",  Token
At ),
 ( "~",  Token
Tilde ),
 ( "=>", Token
DoubleArrow )
 ]

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

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

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

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

matchChar :: Char -> String -> Lex a ()
matchChar :: Char -> String -> Lex a ()
matchChar c :: Char
c msg :: String
msg = do
        String
s <- Lex a String
forall r. Lex r String
getInput
        if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s Bool -> Bool -> Bool
|| String -> Char
forall a. [a] -> a
head String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
c then String -> Lex a ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg else Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1

-- 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 :: (Token -> P a) -> P a
lexer = Lex a Token -> (Token -> P a) -> P a
forall r a. Lex r a -> (a -> P r) -> P r
runL (Lex a Token -> (Token -> P a) -> P a)
-> Lex a Token -> (Token -> P a) -> P a
forall a b. (a -> b) -> a -> b
$ do
        Bool
bol  <- Lex a Bool
forall a. Lex a Bool
checkBOL
        Bool
bol' <- Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
bol
        Lex a ()
forall a. Lex a ()
startToken
        if Bool
bol' then Lex a Token
forall a. Lex a Token
lexBOL else Lex a Token
forall a. Lex a Token
lexToken

lexWhiteSpace :: Bool -> Lex a Bool
lexWhiteSpace :: Bool -> Lex a Bool
lexWhiteSpace bol :: Bool
bol = do
        String
s <- Lex a String
forall r. Lex r String
getInput
        case String
s of
            '{':'-':_ -> do
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2
                Bool
bol' <- Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexNestedComment Bool
bol
                Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
bol'
            '-':'-':rest :: String
rest | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-') ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isSymbol String
rest) -> do
                String
_ <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-')
                String
_ <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\n')
                String
s' <- Lex a String
forall r. Lex r String
getInput
                case String
s' of
                    [] -> String -> Lex a Bool
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Unterminated end-of-line comment"
                    _ -> do
                        Lex a ()
forall a. Lex a ()
lexNewline
                        Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
True
            '\n':_ -> do
                Lex a ()
forall a. Lex a ()
lexNewline
                Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
True
            '\t':_ -> do
                Lex a ()
forall a. Lex a ()
lexTab
                Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
bol
            c :: Char
c:_ | Char -> Bool
isSpace Char
c -> do
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
                Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexWhiteSpace Bool
bol
            _ -> Bool -> Lex a Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
bol

lexNestedComment :: Bool -> Lex a Bool
lexNestedComment :: Bool -> Lex a Bool
lexNestedComment bol :: Bool
bol = do
        String
s <- Lex a String
forall r. Lex r String
getInput
        case String
s of
            '-':'}':_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Bool -> Lex a Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Lex a Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
bol
            '{':'-':_ -> do
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2
                Bool
bol' <- Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexNestedComment Bool
bol    -- rest of the subcomment
                Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexNestedComment Bool
bol'           -- rest of this comment
            '\t':_    -> Lex a ()
forall a. Lex a ()
lexTab Lex a () -> Lex a Bool -> Lex a Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexNestedComment Bool
bol
            '\n':_    -> Lex a ()
forall a. Lex a ()
lexNewline Lex a () -> Lex a Bool -> Lex a Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexNestedComment Bool
True
            _:_       -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Bool -> Lex a Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Lex a Bool
forall a. Bool -> Lex a Bool
lexNestedComment Bool
bol
            []        -> String -> Lex a Bool
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Unterminated nested comment"

-- 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 :: Lex a Token
lexBOL = do
        Ordering
pos <- Lex a Ordering
forall a. Lex a Ordering
getOffside
        case Ordering
pos of
            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 "lexBOL"
                Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
VRightCurly
            EQ ->
                -- trace "layout: inserting ';'\n" $
                Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
SemiColon
            GT ->
                Lex a Token
forall a. Lex a Token
lexToken

lexToken :: Lex a Token
lexToken :: Lex a Token
lexToken = do
    String
s <- Lex a String
forall r. Lex r String
getInput
    case String
s of
        [] -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
EOF

        '0':c :: Char
c:d :: Char
d:_ | Char -> Char
toLower Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'o' Bool -> Bool -> Bool
&& Char -> Bool
isOctDigit Char
d -> do
                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2
                        Integer
n <- Lex a Integer
forall a. Lex a Integer
lexOctal
                        Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Token
IntTok Integer
n)
                  | Char -> Char
toLower Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'x' Bool -> Bool -> Bool
&& Char -> Bool
isHexDigit Char
d -> do
                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2
                        Integer
n <- Lex a Integer
forall a. Lex a Integer
lexHexadecimal
                        Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Token
IntTok Integer
n)

        c :: Char
c:_ | Char -> Bool
isDigit Char
c -> Lex a Token
forall a. Lex a Token
lexDecimalOrFloat

            | Char -> Bool
isUpper Char
c -> String -> Lex a Token
forall a. String -> Lex a Token
lexConIdOrQual ""

            | Char -> Bool
isLower Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_' -> do
                String
ident <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
                Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ case String -> [(String, Token)] -> Maybe Token
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
ident ([(String, Token)]
reserved_ids [(String, Token)] -> [(String, Token)] -> [(String, Token)]
forall a. [a] -> [a] -> [a]
++ [(String, Token)]
special_varids) of
                        Just keyword :: Token
keyword -> Token
keyword
                        Nothing      -> String -> Token
VarId String
ident

            | Char -> Bool
isSymbol Char
c -> do
                String
sym <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isSymbol
                Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ case String -> [(String, Token)] -> Maybe Token
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
sym ([(String, Token)]
reserved_ops [(String, Token)] -> [(String, Token)] -> [(String, Token)]
forall a. [a] -> [a] -> [a]
++ [(String, Token)]
special_varops) of
                        Just t :: Token
t  -> Token
t
                        Nothing -> case Char
c of
                            ':' -> String -> Token
ConSym String
sym
                            _   -> String -> Token
VarSym String
sym

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

                    -- First the special symbols
                    '(' ->  Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
LeftParen
                    ')' ->  Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RightParen
                    ',' ->  Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
Comma
                    ';' ->  Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
SemiColon
                    '[' ->  Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
LeftSquare
                    ']' ->  Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RightSquare
                    '`' ->  Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
BackQuote
                    '{' -> do
                            LexContext -> Lex a ()
forall a. LexContext -> Lex a ()
pushContextL LexContext
NoLayout
                            Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
LeftCurly
                    '}' -> do
                            String -> Lex a ()
forall a. String -> Lex a ()
popContextL "lexToken"
                            Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RightCurly

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

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

                    _ ->    String -> Lex a Token
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("Illegal character \'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\'\n")

lexDecimalOrFloat :: Lex a Token
lexDecimalOrFloat :: Lex a Token
lexDecimalOrFloat = do
        String
ds <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isDigit
        String
rest <- Lex a String
forall r. Lex r String
getInput
        case String
rest of
            ('.':d :: Char
d:_) | Char -> Bool
isDigit Char
d -> do
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
                String
frac <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isDigit
                let num :: Integer
num = Integer -> String -> Integer
parseInteger 10 (String
ds String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
frac)
                    decimals :: Integer
decimals = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
frac)
                Integer
exponent' <- do
                        String
rest2 <- Lex a String
forall r. Lex r String
getInput
                        case String
rest2 of
                            'e':_ -> Lex a Integer
forall a. Lex a Integer
lexExponent
                            'E':_ -> Lex a Integer
forall a. Lex a Integer
lexExponent
                            _     -> Integer -> Lex a Integer
forall (m :: * -> *) a. Monad m => a -> m a
return 0
                Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Rational -> Token
FloatTok ((Integer
numInteger -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%1) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* 10Rational -> Integer -> Rational
forall a b. (Fractional a, Integral b) => a -> b -> a
^^(Integer
exponent' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
decimals)))
            e :: Char
e:_ | Char -> Char
toLower Char
e Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'e' -> do
                Integer
exponent' <- Lex a Integer
forall a. Lex a Integer
lexExponent
                Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Rational -> Token
FloatTok ((Integer -> String -> Integer
parseInteger 10 String
dsInteger -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%1) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* 10Rational -> Integer -> Rational
forall a b. (Fractional a, Integral b) => a -> b -> a
^^Integer
exponent'))
            _ -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Token
IntTok (Integer -> String -> Integer
parseInteger 10 String
ds))

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

lexConIdOrQual :: String -> Lex a Token
lexConIdOrQual :: String -> Lex a Token
lexConIdOrQual qual :: String
qual = do
        String
con <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
        let conid :: Token
conid | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
qual = String -> Token
ConId String
con
                  | Bool
otherwise = (String, String) -> Token
QConId (String
qual,String
con)
            qual' :: String
qual' | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
qual = String
con
                  | Bool
otherwise = String
qual String -> ShowS
forall a. [a] -> [a] -> [a]
++ '.'Char -> ShowS
forall a. a -> [a] -> [a]
:String
con
        Lex a Token
just_a_conid <- Lex a Token -> Lex a (Lex a Token)
forall a v. Lex a v -> Lex a (Lex a v)
alternative (Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
conid)
        String
rest <- Lex a String
forall r. Lex r String
getInput
        case String
rest of
          '.':c :: Char
c:_
             | Char -> Bool
isLower Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_' -> do      -- qualified varid?
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
                String
ident <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
                case String -> [(String, Token)] -> Maybe Token
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
ident [(String, Token)]
reserved_ids of
                   -- cannot qualify a reserved word
                   Just _  -> Lex a Token
just_a_conid
                   Nothing -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> Token
QVarId (String
qual', String
ident))

             | Char -> Bool
isUpper Char
c -> do          -- qualified conid?
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
                String -> Lex a Token
forall a. String -> Lex a Token
lexConIdOrQual String
qual'

             | Char -> Bool
isSymbol Char
c -> do -- qualified symbol?
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
                String
sym <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isSymbol
                case String -> [(String, Token)] -> Maybe Token
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
sym [(String, Token)]
reserved_ops of
                    -- cannot qualify a reserved operator
                    Just _  -> Lex a Token
just_a_conid
                    Nothing -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ case Char
c of
                        ':' -> (String, String) -> Token
QConSym (String
qual', String
sym)
                        _   -> (String, String) -> Token
QVarSym (String
qual', String
sym)

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

lexChar :: Lex a Char
lexChar :: Lex a Char
lexChar = do
        String
r <- Lex a String
forall r. Lex r String
getInput
        case String
r of
                '\\':_ -> Lex a Char
forall a. Lex a Char
lexEscape
                c :: Char
c:_    -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c
                []     -> String -> Lex a Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Incomplete character constant"

lexString :: Lex a Token
lexString :: Lex a Token
lexString = String -> Lex a Token
forall a. String -> Lex a Token
loop ""
    where
        loop :: String -> Lex r Token
loop s :: String
s = do
                String
r <- Lex r String
forall r. Lex r String
getInput
                case String
r of
                    '\\':'&':_ -> do
                                Int -> Lex r ()
forall r. Int -> Lex r ()
discard 2
                                String -> Lex r Token
loop String
s
                    '\\':c :: Char
c:_ | Char -> Bool
isSpace Char
c -> do
                                Int -> Lex r ()
forall r. Int -> Lex r ()
discard 1
                                Lex r ()
forall a. Lex a ()
lexWhiteChars
                                Char -> String -> Lex r ()
forall a. Char -> String -> Lex a ()
matchChar '\\' "Illegal character in string gap"
                                String -> Lex r Token
loop String
s
                             | Bool
otherwise -> do
                                Char
ce <- Lex r Char
forall a. Lex a Char
lexEscape
                                String -> Lex r Token
loop (Char
ceChar -> ShowS
forall a. a -> [a] -> [a]
:String
s)
                    '"':_ -> do
                                Int -> Lex r ()
forall r. Int -> Lex r ()
discard 1
                                Token -> Lex r Token
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Token
StringTok (ShowS
forall a. [a] -> [a]
reverse String
s))
                    c :: Char
c:_ -> do
                                Int -> Lex r ()
forall r. Int -> Lex r ()
discard 1
                                String -> Lex r Token
loop (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
s)
                    [] ->       String -> Lex r Token
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Improperly terminated string"

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

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

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

                'a':_           -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\a'
                'b':_           -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\b'
                'f':_           -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\f'
                'n':_           -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\n'
                'r':_           -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\r'
                't':_           -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\t'
                'v':_           -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\v'
                '\\':_          -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\\'
                '"':_           -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\"'
                '\'':_          -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Char -> Lex a Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return '\''

-- Production ascii from section B.2

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

-- Escaped numbers

                'o':c :: Char
c:_ | Char -> Bool
isOctDigit Char
c -> do
                                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
                                        Integer
n <- Lex a Integer
forall a. Lex a Integer
lexOctal
                                        Integer -> Lex a Char
forall (m :: * -> *). MonadFail m => Integer -> m Char
checkChar Integer
n
                'x':c :: Char
c:_ | Char -> Bool
isHexDigit Char
c -> do
                                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
                                        Integer
n <- Lex a Integer
forall a. Lex a Integer
lexHexadecimal
                                        Integer -> Lex a Char
forall (m :: * -> *). MonadFail m => Integer -> m Char
checkChar Integer
n
                c :: Char
c:_ | Char -> Bool
isDigit Char
c -> do
                                        Integer
n <- Lex a Integer
forall a. Lex a Integer
lexDecimal
                                        Integer -> Lex a Char
forall (m :: * -> *). MonadFail m => Integer -> m Char
checkChar Integer
n

                _               -> String -> Lex a Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Illegal escape sequence"

    where
        checkChar :: Integer -> m Char
checkChar n :: Integer
n | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x10FFFF = Char -> m Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n))
        checkChar _ = String -> m Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Character constant out of range"

-- Production cntrl from section B.2

        cntrl :: Char -> Lex a Char
        cntrl :: Char -> Lex a Char
cntrl c :: Char
c | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '@' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '_' = Char -> Lex a Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord '@'))
        cntrl _ = String -> Lex a Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Illegal control character"

-- assumes at least one octal digit
lexOctal :: Lex a Integer
lexOctal :: Lex a Integer
lexOctal = do
        String
ds <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isOctDigit
        Integer -> Lex a Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> String -> Integer
parseInteger 8 String
ds)

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

-- assumes at least one decimal digit
lexDecimal :: Lex a Integer
lexDecimal :: Lex a Integer
lexDecimal = do
        String
ds <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isDigit
        Integer -> Lex a Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> String -> Integer
parseInteger 10 String
ds)

-- Stolen from Hugs's Prelude
parseInteger :: Integer -> String -> Integer
parseInteger :: Integer -> String -> Integer
parseInteger radix :: Integer
radix ds :: String
ds =
        (Integer -> Integer -> Integer) -> [Integer] -> Integer
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\n :: Integer
n d :: Integer
d -> Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
radix Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
d) ((Char -> Integer) -> String -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> (Char -> Int) -> Char -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
digitToInt) String
ds)