    -----------------------------------------------------------------------------
    -- |
    -- 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)