    -----------------------------------------------------------------------------
    The lexer.

    (c) 1993-2001 Andy Gill, Simon Marlow
    -----------------------------------------------------------------------------

    > module Happy.Frontend.Lexer (
    >       Token(..),
    >       TokenId(..),
    >       HasLexer(..) ) where

    > import Happy.Frontend.ParseMonad.Class

    > import Data.Char ( isSpace, isAlphaNum, isDigit, digitToInt )

    > data Token
    >       = TokenInfo String TokenId
    >       | TokenNum  Int    TokenId
    >       | TokenKW          TokenId
    >       | TokenEOF

    > tokenToId :: Token -> TokenId
    > tokenToId :: Token -> TokenId
    tokenToId (TokenInfo String
    _ TokenId
    i) = TokenId
    i
    > tokenToId (TokenNum Int
    _ TokenId
    i) = TokenId
    i
    > tokenToId (TokenKW TokenId
    i) = TokenId
    i
    > tokenToId Token
    TokenEOF = String -> TokenId
    forall a. HasCallStack => String -> a
    error String
    "tokenToId TokenEOF"

    > instance Eq Token where
    >       Token
    i == :: Token -> Token -> Bool
    == Token
    i' = Token -> TokenId
    tokenToId Token
    i TokenId -> TokenId -> Bool
    forall a. Eq a => a -> a -> Bool
    == Token -> TokenId
    tokenToId Token
    i'

    > instance Ord Token where
    >       Token
    i <= :: Token -> Token -> Bool
    <= Token
    i' = Token -> TokenId
    tokenToId Token
    i TokenId -> TokenId -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Token -> TokenId
    tokenToId Token
    i'

    > data TokenId
    >       = TokId                 -- words and symbols
    >       | TokSpecId_TokenType   -- %tokentype
    >       | TokSpecId_Token       -- %token
    >       | TokSpecId_Name        -- %name
    >       | TokSpecId_Partial     -- %partial
    >       | TokSpecId_Lexer       -- %lexer
    >       | TokSpecId_ImportedIdentity -- %importedidentity
    >       | TokSpecId_Monad       -- %monad
    >       | TokSpecId_Nonassoc    -- %nonassoc
    >       | TokSpecId_Left        -- %left
    >       | TokSpecId_Right       -- %right
    >       | TokSpecId_Prec        -- %prec
    >       | TokSpecId_Shift       -- %shift
    >       | TokSpecId_Expect      -- %expect
    >       | TokSpecId_Error       -- %error
    >       | TokSpecId_ErrorExpected -- %error.expected
    >       | TokSpecId_ErrorHandlerType -- %errorhandlertype
    >       | TokSpecId_Attributetype -- %attributetype
    >       | TokSpecId_Attribute   -- %attribute
    >       | TokPragmaQuote        -- stuff inside {-# .. #-}
    >       | TokCodeQuote          -- stuff inside { .. }
    >       | TokColon              -- :
    >       | TokSemiColon          -- ;
    >       | TokDoubleColon        -- ::
    >       | TokDoublePercent      -- %%
    >       | TokBar                -- |
    >       | TokNum                -- Integer
    >       | TokParenL             -- (
    >       | TokParenR             -- )
    >       | TokComma              -- ,
    >       deriving (TokenId -> TokenId -> Bool
    (TokenId -> TokenId -> Bool)
    -> (TokenId -> TokenId -> Bool) -> Eq TokenId
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: TokenId -> TokenId -> Bool
    == :: TokenId -> TokenId -> Bool
    $c/= :: TokenId -> TokenId -> Bool
    /= :: TokenId -> TokenId -> Bool
    Eq,Eq TokenId
    Eq TokenId =>
    (TokenId -> TokenId -> Ordering)
    -> (TokenId -> TokenId -> Bool)
    -> (TokenId -> TokenId -> Bool)
    -> (TokenId -> TokenId -> Bool)
    -> (TokenId -> TokenId -> Bool)
    -> (TokenId -> TokenId -> TokenId)
    -> (TokenId -> TokenId -> TokenId)
    -> Ord TokenId
    TokenId -> TokenId -> Bool
    TokenId -> TokenId -> Ordering
    TokenId -> TokenId -> TokenId
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: TokenId -> TokenId -> Ordering
    compare :: TokenId -> TokenId -> Ordering
    $c< :: TokenId -> TokenId -> Bool
    < :: TokenId -> TokenId -> Bool
    $c<= :: TokenId -> TokenId -> Bool
    <= :: TokenId -> TokenId -> Bool
    $c> :: TokenId -> TokenId -> Bool
    > :: TokenId -> TokenId -> Bool
    $c>= :: TokenId -> TokenId -> Bool
    >= :: TokenId -> TokenId -> Bool
    $cmax :: TokenId -> TokenId -> TokenId
    max :: TokenId -> TokenId -> TokenId
    $cmin :: TokenId -> TokenId -> TokenId
    min :: TokenId -> TokenId -> TokenId
    Ord,Int -> TokenId -> ShowS
    [TokenId] -> ShowS
    TokenId -> String
    (Int -> TokenId -> ShowS)
    -> (TokenId -> String) -> ([TokenId] -> ShowS) -> Show TokenId
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> TokenId -> ShowS
    showsPrec :: Int -> TokenId -> ShowS
    $cshow :: TokenId -> String
    show :: TokenId -> String
    $cshowList :: [TokenId] -> ShowS
    showList :: [TokenId] -> ShowS
    Show)

    ToDo: proper text instance here, for use in parser error messages.

    > instance HasLexer Token where
    >   lexToken :: forall r. (Token -> Pfunc r) -> Pfunc r
    lexToken = (Token -> Pfunc r) -> Pfunc r
    forall r. (Token -> Pfunc r) -> Pfunc r
    lexer

    > lexer :: (Token -> Pfunc a) -> Pfunc a
    > lexer :: forall r. (Token -> Pfunc r) -> Pfunc r
    lexer Token -> Pfunc a
    cont = Pfunc a
    lexer'
    >   where lexer' :: Pfunc a
    lexer' String
    "" = Token -> Pfunc a
    cont Token
    TokenEOF String
    ""
    >         lexer' (Char
    '-':Char
    '-':String
    r) = Pfunc a
    lexer' ((Char -> Bool) -> ShowS
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '\n') String
    r)
    >         lexer' (Char
    '{':Char
    '-':Char
    '#':String
    r) = (Token -> Pfunc a) -> Pfunc a
    forall r. (Token -> Pfunc r) -> Pfunc r
    lexPragma Token -> Pfunc a
    cont String
    r
    >         lexer' (Char
    '{':Char
    '-':String
    r) = \Int
    line -> Int -> Pfunc a -> Pfunc a
    forall a.
    Int
    -> (String -> Int -> ParseResult a)
    -> String
    -> Int
    -> ParseResult a
    lexNestedComment Int
    line Pfunc a
    lexer' String
    r Int
    line
    >         lexer' (Char
    c:String
    rest) = (Token -> Pfunc a) -> Char -> Pfunc a
    forall a. (Token -> Pfunc a) -> Char -> Pfunc a
    nextLex Token -> Pfunc a
    cont Char
    c String
    rest

    > nextLex :: (Token -> Pfunc a) -> Char -> String -> Int -> ParseResult a
    > nextLex :: forall a. (Token -> Pfunc a) -> Char -> Pfunc a
    nextLex Token -> Pfunc a
    cont Char
    c = case Char
    c of
    >       Char
    '\n'    -> \String
    rest Int
    line -> (Token -> Pfunc a) -> Pfunc a
    forall r. (Token -> Pfunc r) -> Pfunc r
    lexer Token -> Pfunc a
    cont String
    rest (Int
    lineInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1)
    >       Char
    '%'     -> (Token -> Pfunc a) -> Pfunc a
    forall r. (Token -> Pfunc r) -> Pfunc r
    lexPercent Token -> Pfunc a
    cont
    >       Char
    ':'     -> (Token -> Pfunc a) -> Pfunc a
    forall r. (Token -> Pfunc r) -> Pfunc r
    lexColon Token -> Pfunc a
    cont
    >       Char
    ';'     -> Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSemiColon)

    >       Char
    '|'     -> Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokBar)
    >       Char
    '\''    -> (Token -> Pfunc a) -> Pfunc a
    forall r. (Token -> Pfunc r) -> Pfunc r
    lexChar Token -> Pfunc a
    cont
    >       Char
    '"'{-"-}-> (Token -> Pfunc a) -> Pfunc a
    forall r. (Token -> Pfunc r) -> Pfunc r
    lexString Token -> Pfunc a
    cont
    >       Char
    '{'     -> (Token -> Pfunc a) -> Pfunc a
    forall r. (Token -> Pfunc r) -> Pfunc r
    lexCode Token -> Pfunc a
    cont

    >       Char
    '('     -> Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokParenL)
    >       Char
    ')'     -> Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokParenR)
    >       Char
    ','     -> Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokComma)

    >       Char
    _
    >         | Char -> Bool
    isSpace Char
    c -> (Token -> Pfunc a) -> Pfunc a
    forall r. (Token -> Pfunc r) -> Pfunc r
    lexer Token -> Pfunc a
    cont
    >         |  Char
    c Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Char
    'a' Bool -> Bool -> Bool
    && Char
    c Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Char
    'z'
    >            Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Char
    'A' Bool -> Bool -> Bool
    && Char
    c Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Char
    'Z' -> (Token -> Pfunc a) -> Char -> Pfunc a
    forall a. (Token -> Pfunc a) -> Char -> Pfunc a
    lexId Token -> Pfunc a
    cont Char
    c
    >         | Char -> Bool
    isDigit Char
    c -> (Token -> Pfunc a) -> Char -> Pfunc a
    forall a. (Token -> Pfunc a) -> Char -> Pfunc a
    lexNum Token -> Pfunc a
    cont Char
    c
    >       Char
    _       -> String -> Pfunc a
    forall a. String -> String -> Int -> ParseResult a
    lexError (String
    "lexical error before `" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Char
    c Char -> ShowS
    forall a. a -> [a] -> [a]
    : String
    "'")

    Percents come in two forms, in pairs, or
    followed by a special identifier.

    > lexPercent :: (Token -> Pfunc a) -> [Char] -> Int -> ParseResult a
    > lexPercent :: forall r. (Token -> Pfunc r) -> Pfunc r
    lexPercent Token -> Pfunc a
    cont String
    s = case String
    s of
    >       Char
    '%':String
    rest -> Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokDoublePercent) String
    rest
    >       Char
    't':Char
    'o':Char
    'k':Char
    'e':Char
    'n':Char
    't':Char
    'y':Char
    'p':Char
    'e':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_TokenType) String
    rest
    >       Char
    't':Char
    'o':Char
    'k':Char
    'e':Char
    'n':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_Token) String
    rest
    >       Char
    'n':Char
    'a':Char
    'm':Char
    'e':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_Name) String
    rest
    >       Char
    'p':Char
    'a':Char
    'r':Char
    't':Char
    'i':Char
    'a':Char
    'l':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_Partial) String
    rest
    >       Char
    'i':Char
    'm':Char
    'p':Char
    'o':Char
    'r':Char
    't':Char
    'e':Char
    'd':Char
    'i':Char
    'd':Char
    'e':Char
    'n':Char
    't':Char
    'i':Char
    't':Char
    'y':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_ImportedIdentity) String
    rest
    >       Char
    'm':Char
    'o':Char
    'n':Char
    'a':Char
    'd':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_Monad) String
    rest
    >       Char
    'l':Char
    'e':Char
    'x':Char
    'e':Char
    'r':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_Lexer) String
    rest
    >       Char
    'n':Char
    'o':Char
    'n':Char
    'a':Char
    's':Char
    's':Char
    'o':Char
    'c':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_Nonassoc) String
    rest
    >       Char
    'l':Char
    'e':Char
    'f':Char
    't':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_Left) String
    rest
    >       Char
    'r':Char
    'i':Char
    'g':Char
    'h':Char
    't':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_Right) String
    rest
    >       Char
    'p':Char
    'r':Char
    'e':Char
    'c':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_Prec) String
    rest
    >       Char
    's':Char
    'h':Char
    'i':Char
    'f':Char
    't':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_Shift) String
    rest
    >       Char
    'e':Char
    'x':Char
    'p':Char
    'e':Char
    'c':Char
    't':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_Expect) String
    rest
    >       Char
    'e':Char
    'r':Char
    'r':Char
    'o':Char
    'r':Char
    '.':Char
    'e':Char
    'x':Char
    'p':Char
    'e':Char
    'c':Char
    't':Char
    'e':Char
    'd':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_ErrorExpected) String
    rest
    >       Char
    'e':Char
    'r':Char
    'r':Char
    'o':Char
    'r':Char
    'h':Char
    'a':Char
    'n':Char
    'd':Char
    'l':Char
    'e':Char
    'r':Char
    't':Char
    'y':Char
    'p':Char
    'e':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_ErrorHandlerType) String
    rest
    >       Char
    'e':Char
    'r':Char
    'r':Char
    'o':Char
    'r':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_Error) String
    rest
    >       Char
    'a':Char
    't':Char
    't':Char
    'r':Char
    'i':Char
    'b':Char
    'u':Char
    't':Char
    'e':Char
    't':Char
    'y':Char
    'p':Char
    'e':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_Attributetype) String
    rest
    >       Char
    'a':Char
    't':Char
    't':Char
    'r':Char
    'i':Char
    'b':Char
    'u':Char
    't':Char
    'e':String
    rest | String -> Bool
    end_of_id String
    rest ->
    >               Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokSpecId_Attribute) String
    rest
    >       String
    _ -> String -> Pfunc a
    forall a. String -> String -> Int -> ParseResult a
    lexError (String
    "unrecognised directive: %" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++
    >                               (Char -> Bool) -> ShowS
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (Bool -> Bool
    not(Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .Char -> Bool
    isSpace) String
    s) String
    s
    >    where
    >       end_of_id :: String -> Bool
    end_of_id (Char
    c:String
    _) = Bool -> Bool
    not (Char -> Bool
    isAlphaNum Char
    c)
    >       end_of_id []    = Bool
    True

    > lexColon :: (Token -> Pfunc a) -> [Char] -> Int -> ParseResult a
    > lexColon :: forall r. (Token -> Pfunc r) -> Pfunc r
    lexColon Token -> Pfunc a
    cont (Char
    ':':String
    rest) = Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokDoubleColon) String
    rest
    > lexColon Token -> Pfunc a
    cont String
    rest       = Token -> Pfunc a
    cont (TokenId -> Token
    TokenKW TokenId
    TokColon) String
    rest

    > lexId :: (Token -> Pfunc a) -> Char -> String -> Int -> ParseResult a
    > lexId :: forall a. (Token -> Pfunc a) -> Char -> Pfunc a
    lexId Token -> Pfunc a
    cont Char
    c String
    rest =
    >       String -> (String -> Pfunc a) -> Int -> ParseResult a
    forall a. String -> (String -> String -> a) -> a
    readId String
    rest (\ String
    ident String
    rest' -> Token -> Pfunc a
    cont (String -> TokenId -> Token
    TokenInfo (Char
    cChar -> ShowS
    forall a. a -> [a] -> [a]
    :String
    ident) TokenId
    TokId) String
    rest')

    > lexChar :: (Token -> Pfunc a) -> String -> Int -> ParseResult a
    > lexChar :: forall r. (Token -> Pfunc r) -> Pfunc r
    lexChar Token -> Pfunc a
    cont String
    rest = String -> (String -> Pfunc a) -> Int -> ParseResult a
    forall a. String -> (String -> String -> a) -> a
    lexReadChar String
    rest
    >       (\ String
    ident -> Token -> Pfunc a
    cont (String -> TokenId -> Token
    TokenInfo (String
    "'" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    ident String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "'") TokenId
    TokId))

    > lexString :: (Token -> Pfunc a) -> String -> Int -> ParseResult a
    > lexString :: forall r. (Token -> Pfunc r) -> Pfunc r
    lexString Token -> Pfunc a
    cont String
    rest = String -> (String -> Pfunc a) -> Int -> ParseResult a
    forall a. String -> (String -> String -> a) -> a
    lexReadString String
    rest
    >       (\ String
    ident -> Token -> Pfunc a
    cont (String -> TokenId -> Token
    TokenInfo (String
    "\"" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    ident String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "\"") TokenId
    TokId))

    > lexCode :: (Token -> Pfunc a) -> String -> Int -> ParseResult a
    > lexCode :: forall r. (Token -> Pfunc r) -> Pfunc r
    lexCode Token -> Pfunc a
    cont String
    rest = String
    -> Integer -> String -> (Token -> Pfunc a) -> Int -> ParseResult a
    forall a b.
    (Eq a, Num a) =>
    String -> a -> String -> (Token -> Pfunc b) -> Int -> ParseResult b
    lexReadCode String
    rest (Integer
    0 :: Integer) String
    "" Token -> Pfunc a
    cont

    > lexNum :: (Token -> Pfunc a) -> Char -> String -> Int -> ParseResult a
    > lexNum :: forall a. (Token -> Pfunc a) -> Char -> Pfunc a
    lexNum Token -> Pfunc a
    cont Char
    c String
    rest =
    >        String -> (String -> Pfunc a) -> Int -> ParseResult a
    forall a. String -> (String -> String -> a) -> a
    readNum String
    rest (\ String
    num String
    rest' ->
    >                         Token -> Pfunc a
    cont (Int -> TokenId -> Token
    TokenNum (String -> Int
    stringToInt (Char
    cChar -> ShowS
    forall a. a -> [a] -> [a]
    :String
    num)) TokenId
    TokNum) String
    rest')
    >  where stringToInt :: String -> Int
    stringToInt = (Int -> Char -> Int) -> Int -> String -> Int
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl (\Int
    n Char
    c' -> Char -> Int
    digitToInt Char
    c' Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    10Int -> Int -> Int
    forall a. Num a => a -> a -> a
    *Int
    n) Int
    0

    > cleanupCode :: String -> String
    > cleanupCode :: ShowS
    cleanupCode String
    s =
    >    (Char -> Bool) -> ShowS
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace (ShowS
    forall a. [a] -> [a]
    reverse ((Char -> Bool) -> ShowS
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile Char -> Bool
    isSpace (ShowS
    forall a. [a] -> [a]
    reverse String
    s)))

    This has to match for @}@ that are {\em not} in strings.  The code
    here is a bit tricky, but should work in most cases.

    > lexReadCode :: (Eq a, Num a)
    >             => String -> a -> String -> (Token -> Pfunc b) -> Int
    >             -> ParseResult b
    > lexReadCode :: forall a b.
    (Eq a, Num a) =>
    String -> a -> String -> (Token -> Pfunc b) -> Int -> ParseResult b
    lexReadCode String
    s a
    n String
    c = case String
    s of
    >       Char
    '\n':String
    r -> \Token -> Pfunc b
    cont Int
    l ->  String -> a -> String -> (Token -> Pfunc b) -> Int -> ParseResult b
    forall a b.
    (Eq a, Num a) =>
    String -> a -> String -> (Token -> Pfunc b) -> Int -> ParseResult b
    lexReadCode String
    r a
    n (Char
    '\n'Char -> ShowS
    forall a. a -> [a] -> [a]
    :String
    c) Token -> Pfunc b
    cont (Int
    lInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1)

    >       Char
    '{' :String
    r -> String -> a -> String -> (Token -> Pfunc b) -> Int -> ParseResult b
    forall a b.
    (Eq a, Num a) =>
    String -> a -> String -> (Token -> Pfunc b) -> Int -> ParseResult b
    lexReadCode String
    r (a
    na -> a -> a
    forall a. Num a => a -> a -> a
    +a
    1) (Char
    '{'Char -> ShowS
    forall a. a -> [a] -> [a]
    :String
    c)

    >       Char
    '}' :String
    r
    >               | a
    n a -> a -> Bool
    forall a. Eq a => a -> a -> Bool
    == a
    0    -> \Token -> Pfunc b
    cont -> Token -> Pfunc b
    cont (String -> TokenId -> Token
    TokenInfo (
    >                               ShowS
    cleanupCode (ShowS
    forall a. [a] -> [a]
    reverse String
    c)) TokenId
    TokCodeQuote) String
    r
    >               | Bool
    otherwise -> String -> a -> String -> (Token -> Pfunc b) -> Int -> ParseResult b
    forall a b.
    (Eq a, Num a) =>
    String -> a -> String -> (Token -> Pfunc b) -> Int -> ParseResult b
    lexReadCode String
    r (a
    na -> a -> a
    forall a. Num a => a -> a -> a
    -a
    1) (Char
    '}'Char -> ShowS
    forall a. a -> [a] -> [a]
    :String
    c)

    >       Char
    '"'{-"-}:String
    r -> String
    -> (String -> String -> (Token -> Pfunc b) -> Int -> ParseResult b)
    -> (Token -> Pfunc b)
    -> Int
    -> ParseResult b
    forall a. String -> (String -> String -> a) -> a
    lexReadString String
    r (\ String
    str String
    r' ->
    >                     String -> a -> String -> (Token -> Pfunc b) -> Int -> ParseResult b
    forall a b.
    (Eq a, Num a) =>
    String -> a -> String -> (Token -> Pfunc b) -> Int -> ParseResult b
    lexReadCode String
    r' a
    n (Char
    '"' Char -> ShowS
    forall a. a -> [a] -> [a]
    : (ShowS
    forall a. [a] -> [a]
    reverse String
    str) String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Char
    '"' Char -> ShowS
    forall a. a -> [a] -> [a]
    : String
    c))

    >       Char
    a: Char
    '\'':String
    r | Char -> Bool
    isAlphaNum Char
    a -> String -> a -> String -> (Token -> Pfunc b) -> Int -> ParseResult b
    forall a b.
    (Eq a, Num a) =>
    String -> a -> String -> (Token -> Pfunc b) -> Int -> ParseResult b
    lexReadCode String
    r a
    n (Char
    '\''Char -> ShowS
    forall a. a -> [a] -> [a]
    :Char
    aChar -> ShowS
    forall a. a -> [a] -> [a]
    :String
    c)

    >       Char
    '\'' :String
    r -> String
    -> (String -> String -> (Token -> Pfunc b) -> Int -> ParseResult b)
    -> (Token -> Pfunc b)
    -> Int
    -> ParseResult b
    forall a. String -> (String -> String -> a) -> a
    lexReadSingleChar String
    r (\ String
    str String
    r' ->
    >                  String -> a -> String -> (Token -> Pfunc b) -> Int -> ParseResult b
    forall a b.
    (Eq a, Num a) =>
    String -> a -> String -> (Token -> Pfunc b) -> Int -> ParseResult b
    lexReadCode String
    r' a
    n ((ShowS
    forall a. [a] -> [a]
    reverse String
    str) String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Char
    '\'' Char -> ShowS
    forall a. a -> [a] -> [a]
    : String
    c))

    >       Char
    ch:String
    r -> String -> a -> String -> (Token -> Pfunc b) -> Int -> ParseResult b
    forall a b.
    (Eq a, Num a) =>
    String -> a -> String -> (Token -> Pfunc b) -> Int -> ParseResult b
    lexReadCode String
    r a
    n (Char
    chChar -> ShowS
    forall a. a -> [a] -> [a]
    :String
    c)

    >       [] -> \Token -> Pfunc b
    _cont -> String -> Pfunc b
    forall a. String -> String -> Int -> ParseResult a
    lexError String
    "No closing '}' in code segment" []

    We need to take similar care when parsing pragmas.

    > lexPragma :: (Token -> Pfunc a) -> String -> Int -> ParseResult a
    > lexPragma :: forall r. (Token -> Pfunc r) -> Pfunc r
    lexPragma Token -> Pfunc a
    cont String
    s = String -> String -> (Token -> Pfunc a) -> Int -> ParseResult a
    forall a.
    String -> String -> (Token -> Pfunc a) -> Int -> ParseResult a
    lexReadPragma String
    s String
    "" Token -> Pfunc a
    cont

    > lexReadPragma :: String -> String -> (Token -> Pfunc a) -> Int -> ParseResult a
    > lexReadPragma :: forall a.
    String -> String -> (Token -> Pfunc a) -> Int -> ParseResult a
    lexReadPragma String
    s String
    c =  case String
    s of
    >       Char
    '#':Char
    '-':Char
    '}':String
    r -> \Token -> Pfunc a
    cont -> Token -> Pfunc a
    cont (String -> TokenId -> Token
    TokenInfo (ShowS
    cleanupCode (ShowS
    forall a. [a] -> [a]
    reverse String
    c)) TokenId
    TokPragmaQuote) String
    r
    >       Char
    '\n':String
    r -> \Token -> Pfunc a
    cont Int
    l -> String -> String -> (Token -> Pfunc a) -> Int -> ParseResult a
    forall a.
    String -> String -> (Token -> Pfunc a) -> Int -> ParseResult a
    lexReadPragma String
    r (Char
    '\n'Char -> ShowS
    forall a. a -> [a] -> [a]
    :String
    c) Token -> Pfunc a
    cont (Int
    lInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1)
    >       Char
    '"'{-"-}:String
    r -> String
    -> (String -> String -> (Token -> Pfunc a) -> Int -> ParseResult a)
    -> (Token -> Pfunc a)
    -> Int
    -> ParseResult a
    forall a. String -> (String -> String -> a) -> a
    lexReadString String
    r (\ String
    str String
    r' ->
    >                     String -> String -> (Token -> Pfunc a) -> Int -> ParseResult a
    forall a.
    String -> String -> (Token -> Pfunc a) -> Int -> ParseResult a
    lexReadPragma String
    r' (Char
    '"' Char -> ShowS
    forall a. a -> [a] -> [a]
    : (ShowS
    forall a. [a] -> [a]
    reverse String
    str) String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Char
    '"' Char -> ShowS
    forall a. a -> [a] -> [a]
    : String
    c))
    >       Char
    a: Char
    '\'':String
    r | Char -> Bool
    isAlphaNum Char
    a -> String -> String -> (Token -> Pfunc a) -> Int -> ParseResult a
    forall a.
    String -> String -> (Token -> Pfunc a) -> Int -> ParseResult a
    lexReadPragma String
    r (Char
    '\''Char -> ShowS
    forall a. a -> [a] -> [a]
    :Char
    aChar -> ShowS
    forall a. a -> [a] -> [a]
    :String
    c)
    >       Char
    '\'' :String
    r -> String
    -> (String -> String -> (Token -> Pfunc a) -> Int -> ParseResult a)
    -> (Token -> Pfunc a)
    -> Int
    -> ParseResult a
    forall a. String -> (String -> String -> a) -> a
    lexReadSingleChar String
    r (\ String
    str String
    r' ->
    >                  String -> String -> (Token -> Pfunc a) -> Int -> ParseResult a
    forall a.
    String -> String -> (Token -> Pfunc a) -> Int -> ParseResult a
    lexReadPragma String
    r' ((ShowS
    forall a. [a] -> [a]
    reverse String
    str) String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Char
    '\'' Char -> ShowS
    forall a. a -> [a] -> [a]
    : String
    c))
    >       Char
    ch:String
    r -> String -> String -> (Token -> Pfunc a) -> Int -> ParseResult a
    forall a.
    String -> String -> (Token -> Pfunc a) -> Int -> ParseResult a
    lexReadPragma String
    r (Char
    chChar -> ShowS
    forall a. a -> [a] -> [a]
    :String
    c)
    >       [] -> \Token -> Pfunc a
    _cont -> String -> Pfunc a
    forall a. String -> String -> Int -> ParseResult a
    lexError String
    "No closing '#-}' in code segment" []

    ----------------------------------------------------------------------------
    Utilities that read the rest of a token.

    > readId :: String -> (String -> String -> a) -> a
    > readId :: forall a. String -> (String -> String -> a) -> a
    readId (Char
    c:String
    r) String -> String -> a
    fn | Char -> Bool
    isIdPart Char
    c = String -> (String -> String -> a) -> a
    forall a. String -> (String -> String -> a) -> a
    readId String
    r (String -> String -> a
    fn (String -> String -> a) -> ShowS -> String -> String -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (:) Char
    c)
    > readId String
    r     String -> String -> a
    fn = String -> String -> a
    fn [] String
    r

    > readNum :: String -> (String -> String -> a) -> a
    > readNum :: forall a. String -> (String -> String -> a) -> a
    readNum (Char
    c:String
    r) String -> String -> a
    fn | Char -> Bool
    isDigit Char
    c = String -> (String -> String -> a) -> a
    forall a. String -> (String -> String -> a) -> a
    readNum String
    r (String -> String -> a
    fn (String -> String -> a) -> ShowS -> String -> String -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (:) Char
    c)
    > readNum String
    r     String -> String -> a
    fn = String -> String -> a
    fn [] String
    r

    > isIdPart :: Char -> Bool
    > isIdPart :: Char -> Bool
    isIdPart Char
    c =
    >          Char
    c Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Char
    'a' Bool -> Bool -> Bool
    && Char
    c Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Char
    'z'
    >       Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Char
    'A' Bool -> Bool -> Bool
    && Char
    c Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Char
    'Z'
    >       Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Char
    '0' Bool -> Bool -> Bool
    && Char
    c Char -> Char -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Char
    '9'
    >       Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '_'

    > lexReadSingleChar :: String -> (String -> String -> a) -> a
    > lexReadSingleChar :: forall a. String -> (String -> String -> a) -> a
    lexReadSingleChar (Char
    '\\':Char
    c:Char
    '\'':String
    r) String -> String -> a
    fn = String -> String -> a
    fn (Char
    '\\'Char -> ShowS
    forall a. a -> [a] -> [a]
    :Char
    cChar -> ShowS
    forall a. a -> [a] -> [a]
    :String
    "'") String
    r
    > lexReadSingleChar (Char
    c:Char
    '\'':String
    r)      String -> String -> a
    fn = String -> String -> a
    fn (Char
    cChar -> ShowS
    forall a. a -> [a] -> [a]
    :String
    "'") String
    r
    > lexReadSingleChar String
    r               String -> String -> a
    fn = String -> String -> a
    fn String
    "" String
    r

    > lexReadChar :: String -> (String -> String -> a) -> a
    > lexReadChar :: forall a. String -> (String -> String -> a) -> a
    lexReadChar (Char
    '\'':String
    r)      String -> String -> a
    fn = String -> String -> a
    fn String
    "" String
    r
    > lexReadChar (Char
    '\\':Char
    '\'':String
    r) String -> String -> a
    fn = String -> (String -> String -> a) -> a
    forall a. String -> (String -> String -> a) -> a
    lexReadChar String
    r (String -> String -> a
    fn (String -> String -> a) -> ShowS -> String -> String -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (:) Char
    '\\' ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (:) Char
    '\'')
    > lexReadChar (Char
    '\\':Char
    c:String
    r)    String -> String -> a
    fn = String -> (String -> String -> a) -> a
    forall a. String -> (String -> String -> a) -> a
    lexReadChar String
    r (String -> String -> a
    fn (String -> String -> a) -> ShowS -> String -> String -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (:) Char
    '\\' ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (:) Char
    c)
    > lexReadChar (Char
    c:String
    r)         String -> String -> a
    fn = String -> (String -> String -> a) -> a
    forall a. String -> (String -> String -> a) -> a
    lexReadChar String
    r (String -> String -> a
    fn (String -> String -> a) -> ShowS -> String -> String -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (:) Char
    c)
    > lexReadChar []            String -> String -> a
    fn = String -> String -> a
    fn String
    "" []

    > lexReadString :: String -> (String -> String -> a) -> a
    > lexReadString :: forall a. String -> (String -> String -> a) -> a
    lexReadString (Char
    '"'{-"-}:String
    r) String -> String -> a
    fn = String -> String -> a
    fn String
    "" String
    r
    > lexReadString (Char
    '\\':Char
    '"':String
    r) String -> String -> a
    fn = String -> (String -> String -> a) -> a
    forall a. String -> (String -> String -> a) -> a
    lexReadString String
    r (String -> String -> a
    fn (String -> String -> a) -> ShowS -> String -> String -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (:) Char
    '\\' ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (:) Char
    '"')
    > lexReadString (Char
    '\\':Char
    c:String
    r)   String -> String -> a
    fn = String -> (String -> String -> a) -> a
    forall a. String -> (String -> String -> a) -> a
    lexReadString String
    r (String -> String -> a
    fn (String -> String -> a) -> ShowS -> String -> String -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (:) Char
    '\\' ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (:) Char
    c)
    > lexReadString (Char
    c:String
    r)        String -> String -> a
    fn = String -> (String -> String -> a) -> a
    forall a. String -> (String -> String -> a) -> a
    lexReadString String
    r (String -> String -> a
    fn (String -> String -> a) -> ShowS -> String -> String -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (:) Char
    c)
    > lexReadString []           String -> String -> a
    fn = String -> String -> a
    fn String
    "" []

    > lexError :: String -> String -> Int -> ParseResult a
    > lexError :: forall a. String -> String -> Int -> ParseResult a
    lexError String
    err = \String
    _ Int
    l -> String -> ParseResult a
    forall a b. a -> Either a b
    Left (Int -> String
    forall a. Show a => a -> String
    show Int
    l String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    ": " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    err String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n")

    > lexNestedComment :: Int -> ([Char] -> Int -> ParseResult a) -> [Char] -> Int
    >                  -> ParseResult a
    > lexNestedComment :: forall a.
    Int
    -> (String -> Int -> ParseResult a)
    -> String
    -> Int
    -> ParseResult a
    lexNestedComment Int
    l String -> Int -> ParseResult a
    cont String
    r =
    >   case String
    r of
    >       Char
    '-':Char
    '}':String
    r' -> String -> Int -> ParseResult a
    cont String
    r'
    >       Char
    '{':Char
    '-':String
    r' -> \Int
    line -> Int
    -> (String -> Int -> ParseResult a)
    -> String
    -> Int
    -> ParseResult a
    forall a.
    Int
    -> (String -> Int -> ParseResult a)
    -> String
    -> Int
    -> ParseResult a
    lexNestedComment Int
    line
    >                       (\String
    r'' -> Int
    -> (String -> Int -> ParseResult a)
    -> String
    -> Int
    -> ParseResult a
    forall a.
    Int
    -> (String -> Int -> ParseResult a)
    -> String
    -> Int
    -> ParseResult a
    lexNestedComment Int
    l String -> Int -> ParseResult a
    cont String
    r'') String
    r' Int
    line
    >       Char
    '\n':String
    r'    -> \Int
    line -> Int
    -> (String -> Int -> ParseResult a)
    -> String
    -> Int
    -> ParseResult a
    forall a.
    Int
    -> (String -> Int -> ParseResult a)
    -> String
    -> Int
    -> ParseResult a
    lexNestedComment Int
    l String -> Int -> ParseResult a
    cont String
    r' (Int
    lineInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1)
    >       Char
    _:String
    r'       -> Int
    -> (String -> Int -> ParseResult a)
    -> String
    -> Int
    -> ParseResult a
    forall a.
    Int
    -> (String -> Int -> ParseResult a)
    -> String
    -> Int
    -> ParseResult a
    lexNestedComment Int
    l String -> Int -> ParseResult a
    cont String
    r'
    >       String
    ""         -> \Int
    _ -> String -> String -> Int -> ParseResult a
    forall a. String -> String -> Int -> ParseResult a
    lexError String
    "unterminated comment" String
    r Int
    l