{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.Exts.Annotated.InternalLexer
-- Copyright   :  (c) The GHC Team, 1997-2000
--                (c) Niklas Broberg, 2004-2009
-- License     :  BSD-style (see the file LICENSE.txt)
--
-- Maintainer  :  Niklas Broberg, d00nibro@chalmers.se
-- Stability   :  stable
-- Portability :  portable
--
-- Lexer for Haskell, with some extensions.
--
-----------------------------------------------------------------------------

-- 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.Exts.InternalLexer (Token(..), showToken, lexer, topLexer) where

import Language.Haskell.Exts.ParseMonad
import Language.Haskell.Exts.SrcLoc hiding (loc)
import Language.Haskell.Exts.Comments
import Language.Haskell.Exts.Extension
import Language.Haskell.Exts.ExtScheme

import Prelude hiding (id, exponent)
import Data.Char
import Data.Ratio
import Data.List (intercalate, isPrefixOf)
import Control.Monad (when)

-- import Debug.Trace (trace)

data Token
        = VarId String
        | LabelVarId String
        | QVarId (String,String)
        | IDupVarId (String)        -- duplicable implicit parameter
        | ILinVarId (String)        -- linear implicit parameter
        | ConId String
        | QConId (String,String)
        | DVarId [String]       -- to enable varid's with '-' in them
        | VarSym String
        | ConSym String
        | QVarSym (String,String)
        | QConSym (String,String)
        | IntTok (Integer, String)
        | FloatTok (Rational, String)
        | Character (Char, String)
        | StringTok (String, String)
        | IntTokHash (Integer, String)        -- 1#
        | WordTokHash (Integer, String)       -- 1##
        | FloatTokHash (Rational, String)     -- 1.0#
        | DoubleTokHash (Rational, String)    -- 1.0##
        | CharacterHash (Char, String)        -- c#
        | StringHash (String, String)         -- "Hello world!"#

-- Symbols

        | LeftParen
        | RightParen
        | LeftHashParen
        | RightHashParen
        | SemiColon
        | LeftCurly
        | RightCurly
        | VRightCurly           -- a virtual close brace
        | LeftSquare
        | RightSquare
        | ParArrayLeftSquare -- [:
        | ParArrayRightSquare -- :]
        | Comma
        | Underscore
        | BackQuote

-- Reserved operators

        | Dot           -- reserved for use with 'forall x . x'
        | DotDot
        | Colon
        | QuoteColon
        | DoubleColon
        | Equals
        | Backslash
        | Bar
        | LeftArrow
        | RightArrow
        | At
        | TApp -- '@' but have to check for preceeding whitespace
        | Tilde
        | DoubleArrow
        | Minus
        | Exclamation
        | Star
        | LeftArrowTail         -- -<
        | RightArrowTail        -- >-
        | LeftDblArrowTail      -- -<<
        | RightDblArrowTail     -- >>-
        | OpenArrowBracket      -- (|
        | CloseArrowBracket     -- |)

-- Template Haskell
        | THExpQuote            -- [| or [e|
        | THTExpQuote           -- [|| or [e||
        | THPatQuote            -- [p|
        | THDecQuote            -- [d|
        | THTypQuote            -- [t|
        | THCloseQuote          -- |]
        | THTCloseQuote         -- ||]
        | THIdEscape (String)   -- dollar x
        | THParenEscape         -- dollar (
        | THTIdEscape String    -- dollar dollar x
        | THTParenEscape        -- double dollar (
        | THVarQuote            -- 'x (but without the x)
        | THTyQuote             -- ''T (but without the T)
        | THQuasiQuote (String,String)  -- [$...|...]

-- HaRP
        | RPGuardOpen       -- (|
        | RPGuardClose      -- |)
        | RPCAt             -- @:

-- Hsx
        | XCodeTagOpen      -- <%
        | XCodeTagClose     -- %>
        | XStdTagOpen       -- <
        | XStdTagClose      -- >
        | XCloseTagOpen     -- </
        | XEmptyTagClose    -- />
        | XChildTagOpen     -- <%> (note that close doesn't exist, it's XCloseTagOpen followed by XCodeTagClose)
        | XPCDATA String
        | XRPatOpen             -- <[
        | XRPatClose            -- ]>

-- Pragmas

        | PragmaEnd                     -- #-}
        | RULES
        | INLINE Bool
        | INLINE_CONLIKE
        | SPECIALISE
        | SPECIALISE_INLINE Bool
        | SOURCE
        | DEPRECATED
        | WARNING
        | SCC
        | GENERATED
        | CORE
        | UNPACK
        | NOUNPACK
        | OPTIONS (Maybe String,String)
--        | CFILES  String
--        | INCLUDE String
        | LANGUAGE
        | ANN
        | MINIMAL
        | NO_OVERLAP
        | OVERLAP
        | OVERLAPPING
        | OVERLAPPABLE
        | OVERLAPS
        | INCOHERENT
        | COMPLETE

-- Reserved Ids

        | KW_As
        | KW_By         -- transform list comprehensions
        | KW_Case
        | KW_Class
        | KW_Data
        | KW_Default
        | KW_Deriving
        | KW_Do
        | KW_MDo
        | KW_Else
        | KW_Family     -- indexed type families
        | KW_Forall     -- universal/existential types
        | KW_Group      -- transform list comprehensions
        | KW_Hiding
        | KW_If
        | KW_Import
        | KW_In
        | KW_Infix
        | KW_InfixL
        | KW_InfixR
        | KW_Instance
        | KW_Let
        | KW_Module
        | KW_NewType
        | KW_Of
        | KW_Proc       -- arrows
        | KW_Rec        -- arrows
        | KW_Role
        | KW_Then
        | KW_Type
        | KW_Using      -- transform list comprehensions
        | KW_Where
        | KW_Qualified
        | KW_Pattern
        | KW_Stock
        | KW_Anyclass
        | KW_Via

                -- FFI
        | KW_Foreign
        | KW_Export
        | KW_Safe
        | KW_Unsafe
        | KW_Threadsafe
        | KW_Interruptible
        | KW_StdCall
        | KW_CCall
        | KW_CPlusPlus
        | KW_DotNet
        | KW_Jvm
        | KW_Js
        | KW_JavaScript
        | KW_CApi

        | EOF
        deriving (Token -> Token -> Bool
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
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, Maybe ExtScheme))]
reserved_ops :: [(String, (Token, Maybe ExtScheme))]
reserved_ops = [
 ( String
"..", (Token
DotDot,       forall a. Maybe a
Nothing) ),
 ( String
":",  (Token
Colon,        forall a. Maybe a
Nothing) ),
 ( String
"::", (Token
DoubleColon,  forall a. Maybe a
Nothing) ),
 ( String
"=",  (Token
Equals,       forall a. Maybe a
Nothing) ),
 ( String
"\\", (Token
Backslash,    forall a. Maybe a
Nothing) ),
 ( String
"|",  (Token
Bar,          forall a. Maybe a
Nothing) ),
 ( String
"<-", (Token
LeftArrow,    forall a. Maybe a
Nothing) ),
 ( String
"->", (Token
RightArrow,   forall a. Maybe a
Nothing) ),
 ( String
"@",  (Token
At,           forall a. Maybe a
Nothing) ),
 ( String
"@:", (Token
RPCAt,        forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
RegularPatterns])) ),
 ( String
"~",  (Token
Tilde,        forall a. Maybe a
Nothing) ),
 ( String
"=>", (Token
DoubleArrow,  forall a. Maybe a
Nothing) ),
 ( String
"*",  (Token
Star,         forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
KindSignatures])) ),
 -- Parallel arrays
 ( String
"[:", (Token
ParArrayLeftSquare,   forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ParallelArrays])) ),
 ( String
":]", (Token
ParArrayRightSquare,  forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ParallelArrays])) ),
 -- Arrows notation
 ( String
"-<",  (Token
LeftArrowTail,       forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
Arrows])) ),
 ( String
">-",  (Token
RightArrowTail,      forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
Arrows])) ),
 ( String
"-<<", (Token
LeftDblArrowTail,    forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
Arrows])) ),
 ( String
">>-", (Token
RightDblArrowTail,   forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
Arrows])) ),
 -- Unicode notation
 ( String
"\x2190",    (Token
LeftArrow,     forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any  [KnownExtension
UnicodeSyntax])) ),
 ( String
"\x2192",    (Token
RightArrow,    forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any  [KnownExtension
UnicodeSyntax])) ),
 ( String
"\x21d2",    (Token
DoubleArrow,   forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any  [KnownExtension
UnicodeSyntax])) ),
 ( String
"\x2237",    (Token
DoubleColon,   forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any  [KnownExtension
UnicodeSyntax])) ),
 ( String
"\x2919",    (Token
LeftArrowTail,     forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
All [KnownExtension
UnicodeSyntax, KnownExtension
Arrows])) ),
 ( String
"\x291a",    (Token
RightArrowTail,    forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
All [KnownExtension
UnicodeSyntax, KnownExtension
Arrows])) ),
 ( String
"\x291b",    (Token
LeftDblArrowTail,  forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
All [KnownExtension
UnicodeSyntax, KnownExtension
Arrows])) ),
 ( String
"\x291c",    (Token
RightDblArrowTail, forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
All [KnownExtension
UnicodeSyntax, KnownExtension
Arrows])) ),
 ( String
"\x2605",    (Token
Star,              forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
All [KnownExtension
UnicodeSyntax, KnownExtension
KindSignatures])) ),
 ( String
"\x2200",    (Token
KW_Forall,         forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
All [KnownExtension
UnicodeSyntax, KnownExtension
ExplicitForAll])) )
 ]

special_varops :: [(String,(Token, Maybe ExtScheme))]
special_varops :: [(String, (Token, Maybe ExtScheme))]
special_varops = [
 -- the dot is only a special symbol together with forall, but can still be used as function composition
 ( String
".",  (Token
Dot,          forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ExplicitForAll, KnownExtension
ExistentialQuantification])) ),
 ( String
"-",  (Token
Minus,        forall a. Maybe a
Nothing) ),
 ( String
"!",  (Token
Exclamation,  forall a. Maybe a
Nothing) )
 ]

reserved_ids :: [(String,(Token, Maybe ExtScheme))]
reserved_ids :: [(String, (Token, Maybe ExtScheme))]
reserved_ids = [
 ( String
"_",         (Token
Underscore,    forall a. Maybe a
Nothing) ),
 ( String
"by",        (Token
KW_By,         forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
TransformListComp])) ),
 ( String
"case",      (Token
KW_Case,       forall a. Maybe a
Nothing) ),
 ( String
"class",     (Token
KW_Class,      forall a. Maybe a
Nothing) ),
 ( String
"data",      (Token
KW_Data,       forall a. Maybe a
Nothing) ),
 ( String
"default",   (Token
KW_Default,    forall a. Maybe a
Nothing) ),
 ( String
"deriving",  (Token
KW_Deriving,   forall a. Maybe a
Nothing) ),
 ( String
"do",        (Token
KW_Do,         forall a. Maybe a
Nothing) ),
 ( String
"else",      (Token
KW_Else,       forall a. Maybe a
Nothing) ),
 ( String
"family",    (Token
KW_Family,     forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
TypeFamilies])) ),        -- indexed type families
 ( String
"forall",    (Token
KW_Forall,     forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ExplicitForAll, KnownExtension
ExistentialQuantification])) ),    -- universal/existential quantification
 ( String
"group",     (Token
KW_Group,      forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
TransformListComp])) ),
 ( String
"if",        (Token
KW_If,         forall a. Maybe a
Nothing) ),
 ( String
"import",    (Token
KW_Import,     forall a. Maybe a
Nothing) ),
 ( String
"in",        (Token
KW_In,         forall a. Maybe a
Nothing) ),
 ( String
"infix",     (Token
KW_Infix,      forall a. Maybe a
Nothing) ),
 ( String
"infixl",    (Token
KW_InfixL,     forall a. Maybe a
Nothing) ),
 ( String
"infixr",    (Token
KW_InfixR,     forall a. Maybe a
Nothing) ),
 ( String
"instance",  (Token
KW_Instance,   forall a. Maybe a
Nothing) ),
 ( String
"let",       (Token
KW_Let,        forall a. Maybe a
Nothing) ),
 ( String
"mdo",       (Token
KW_MDo,        forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
RecursiveDo])) ),
 ( String
"module",    (Token
KW_Module,     forall a. Maybe a
Nothing) ),
 ( String
"newtype",   (Token
KW_NewType,    forall a. Maybe a
Nothing) ),
 ( String
"of",        (Token
KW_Of,         forall a. Maybe a
Nothing) ),
 ( String
"proc",      (Token
KW_Proc,       forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
Arrows])) ),
 ( String
"rec",       (Token
KW_Rec,        forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
Arrows, KnownExtension
RecursiveDo, KnownExtension
DoRec])) ),
 ( String
"then",      (Token
KW_Then,       forall a. Maybe a
Nothing) ),
 ( String
"type",      (Token
KW_Type,       forall a. Maybe a
Nothing) ),
 ( String
"using",     (Token
KW_Using,      forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
TransformListComp])) ),
 ( String
"where",     (Token
KW_Where,      forall a. Maybe a
Nothing) ),
 ( String
"role",      (Token
KW_Role,       forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
RoleAnnotations]))),
 ( String
"pattern",   (Token
KW_Pattern,    forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
PatternSynonyms]))),
 ( String
"stock",     (Token
KW_Stock,      forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
DerivingStrategies]))),
 ( String
"anyclass",  (Token
KW_Anyclass,   forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
DerivingStrategies]))),
 ( String
"via",       (Token
KW_Via,        forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
DerivingVia]))),

-- FFI
 ( String
"foreign",   (Token
KW_Foreign,    forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) )
 ]


special_varids :: [(String,(Token, Maybe ExtScheme))]
special_varids :: [(String, (Token, Maybe ExtScheme))]
special_varids = [
 ( String
"as",        (Token
KW_As,         forall a. Maybe a
Nothing) ),
 ( String
"qualified", (Token
KW_Qualified,  forall a. Maybe a
Nothing) ),
 ( String
"hiding",    (Token
KW_Hiding,     forall a. Maybe a
Nothing) ),

-- FFI
 ( String
"export",        (Token
KW_Export,        forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
 ( String
"safe",          (Token
KW_Safe,          forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface, KnownExtension
SafeImports, KnownExtension
Safe, KnownExtension
Trustworthy])) ),
 ( String
"unsafe",        (Token
KW_Unsafe,        forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
 ( String
"threadsafe",    (Token
KW_Threadsafe,    forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
 ( String
"interruptible", (Token
KW_Interruptible, forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
InterruptibleFFI])) ),
 ( String
"stdcall",       (Token
KW_StdCall,       forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
 ( String
"ccall",         (Token
KW_CCall,         forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
 ( String
"cplusplus",     (Token
KW_CPlusPlus,     forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
 ( String
"dotnet",        (Token
KW_DotNet,        forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
 ( String
"jvm",           (Token
KW_Jvm,           forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
 ( String
"js",            (Token
KW_Js,            forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
 ( String
"javascript",    (Token
KW_JavaScript,    forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
 ( String
"capi",          (Token
KW_CApi,          forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
CApiFFI])) )
 ]

pragmas :: [(String,Token)]
pragmas :: [(String, Token)]
pragmas = [
 ( String
"rules",             Token
RULES           ),
 ( String
"inline",            Bool -> Token
INLINE Bool
True     ),
 ( String
"noinline",          Bool -> Token
INLINE Bool
False    ),
 ( String
"notinline",         Bool -> Token
INLINE Bool
False    ),
 ( String
"specialise",        Token
SPECIALISE      ),
 ( String
"specialize",        Token
SPECIALISE      ),
 ( String
"source",            Token
SOURCE          ),
 ( String
"deprecated",        Token
DEPRECATED      ),
 ( String
"warning",           Token
WARNING         ),
 ( String
"ann",               Token
ANN             ),
 ( String
"scc",               Token
SCC             ),
 ( String
"generated",         Token
GENERATED       ),
 ( String
"core",              Token
CORE            ),
 ( String
"unpack",            Token
UNPACK          ),
 ( String
"nounpack",          Token
NOUNPACK        ),
 ( String
"language",          Token
LANGUAGE        ),
 ( String
"minimal",           Token
MINIMAL         ),
 ( String
"no_overlap",        Token
NO_OVERLAP      ),
 ( String
"overlap",           Token
OVERLAP         ),
 ( String
"overlaps",          Token
OVERLAPS        ),
 ( String
"overlapping",       Token
OVERLAPPING     ),
 ( String
"overlappable",      Token
OVERLAPPABLE    ),
 ( String
"incoherent",        Token
INCOHERENT      ),
 ( String
"complete",          Token
COMPLETE      ),
 ( String
"options",           (Maybe String, String) -> Token
OPTIONS forall a. HasCallStack => a
undefined ) -- we'll tweak it before use - promise!
-- ( "cfiles",            CFILES  undefined ), -- same here...
-- ( "include",           INCLUDE undefined )  -- ...and here!
 ]

isIdent, isHSymbol, isPragmaChar :: Char -> Bool
isIdent :: Char -> Bool
isIdent   Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_'

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

isPragmaChar :: Char -> Bool
isPragmaChar Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_'

isIdentStart :: Char -> Bool
isIdentStart :: Char -> Bool
isIdentStart Char
c = Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isUpper Char
c) Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_'


-- Used in the lexing of type applications
-- Why is it like this? I don't know exactly but this is how it is in
-- GHC's parser.
isOpSymbol :: Char -> Bool
isOpSymbol :: Char -> Bool
isOpSymbol Char
c = Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"!#$%&*+./<=>?@\\^|-~"

-- | Checks whether the character would be legal in some position of a qvar.
--   Means that '..' and "AAA" will pass the test.
isPossiblyQvar :: Char -> Bool
isPossiblyQvar :: Char -> Bool
isPossiblyQvar Char
c = Char -> Bool
isIdent (Char -> Char
toLower Char
c) Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'.'

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

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

lexer :: (Loc Token -> P a) -> P a
lexer :: forall a. (Loc Token -> P a) -> P a
lexer = forall r a. Lex r a -> (a -> P r) -> P r
runL forall a. Lex a (Loc Token)
topLexer

topLexer :: Lex a (Loc Token)
topLexer :: forall a. Lex a (Loc Token)
topLexer = do
    Bool
b <- forall a. Lex a Bool
pullCtxtFlag
    if Bool
b then -- trace (show cf ++ ": " ++ show VRightCurly) $
              -- the lex context state flags that we must do an empty {} - UGLY
              forall a. Lex a ()
setBOL forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Lex a SrcLoc
getSrcLocL forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \SrcLoc
l -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. SrcSpan -> a -> Loc a
Loc (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
l SrcLoc
l) Token
VRightCurly)
     else do
        Bool
bol <- forall a. Lex a Bool
checkBOL
        (Bool
bol', Bool
ws) <- forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
bol
        -- take care of whitespace in PCDATA
        Maybe ExtContext
ec <- forall a. Lex a (Maybe ExtContext)
getExtContext
        case Maybe ExtContext
ec of
         -- if there was no linebreak, and we are lexing PCDATA,
         -- then we want to care about the whitespace.
         -- We don't bother to test for XmlSyntax, since we
         -- couldn't end up in ChildCtxt otherwise.
         Just ExtContext
ChildCtxt | Bool -> Bool
not Bool
bol' Bool -> Bool -> Bool
&& Bool
ws -> forall a. Lex a SrcLoc
getSrcLocL forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \SrcLoc
l -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. SrcSpan -> a -> Loc a
Loc (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
l SrcLoc
l) forall a b. (a -> b) -> a -> b
$ String -> Token
XPCDATA String
" "
         Maybe ExtContext
_ -> do forall a. Lex a ()
startToken
                 SrcLoc
sl <- forall a. Lex a SrcLoc
getSrcLocL
                 Token
t <- if Bool
bol' then forall a. Lex a Token
lexBOL    -- >>= \t -> trace ("BOL: " ++ show t) (return t)
                              else forall a. Lex a Token
lexToken  -- >>= \t -> trace (show t) (return t)
                 SrcLoc
el <- forall a. Lex a SrcLoc
getSrcLocL
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. SrcSpan -> a -> Loc a
Loc (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
sl SrcLoc
el) Token
t

lexWhiteSpace :: Bool -> Lex a (Bool, Bool)
lexWhiteSpace :: forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
bol = do
    String
s <- forall r. Lex r String
getInput
    Bool
ignL <- forall a. Lex a Bool
ignoreLinePragmasL
    case String
s of
        -- If we find a recognised pragma, we don't want to treat it as a comment.
        Char
'{':Char
'-':Char
'#':String
rest | String -> Bool
isRecognisedPragma String
rest -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
bol, Bool
False)
                         | String -> Bool
isLinePragma String
rest Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
ignL -> do
                            (Int
l, String
fn) <- forall a. Lex a (Int, String)
lexLinePragma
                            forall r. Int -> Lex r ()
setSrcLineL Int
l
                            forall a. String -> Lex a ()
setLineFilenameL String
fn
                            forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
True
        Char
'{':Char
'-':String
_ -> do
            SrcLoc
loc <- forall a. Lex a SrcLoc
getSrcLocL
            forall r. Int -> Lex r ()
discard Int
2
            (Bool
bol1, String
c) <- forall a. Bool -> String -> Lex a (Bool, String)
lexNestedComment Bool
bol String
""
            SrcLoc
loc2 <- forall a. Lex a SrcLoc
getSrcLocL
            forall a. Comment -> Lex a ()
pushComment forall a b. (a -> b) -> a -> b
$ Bool -> SrcSpan -> String -> Comment
Comment Bool
True (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
loc SrcLoc
loc2) (forall a. [a] -> [a]
reverse String
c)
            (Bool
bol2, Bool
_) <- forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
bol1
            forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
bol2, Bool
True)
        Char
'-':Char
'-':String
s1 | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== Char
'-') (forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isHSymbol String
s1) -> do
            SrcLoc
loc    <- forall a. Lex a SrcLoc
getSrcLocL
            forall r. Int -> Lex r ()
discard Int
2
            String
dashes <- forall a. (Char -> Bool) -> Lex a String
lexWhile (forall a. Eq a => a -> a -> Bool
== Char
'-')
            String
rest   <- forall a. (Char -> Bool) -> Lex a String
lexWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\n')
            String
s' <- forall r. Lex r String
getInput
            SrcLoc
loc2 <- forall a. Lex a SrcLoc
getSrcLocL
            let com :: Comment
com = Bool -> SrcSpan -> String -> Comment
Comment Bool
False (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
loc SrcLoc
loc2) forall a b. (a -> b) -> a -> b
$ String
dashes forall a. [a] -> [a] -> [a]
++ String
rest
            case String
s' of
                [] -> forall a. Comment -> Lex a ()
pushComment Comment
com forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Bool
True)
                String
_ -> do
                    forall a. Comment -> Lex a ()
pushComment Comment
com
                    forall a. Lex a ()
lexNewline
                    forall a. Bool -> Lex a ()
lexWhiteSpace_ Bool
True
                    forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Bool
True)
        Char
'\n':String
_ -> do
            forall a. Lex a ()
lexNewline
            forall a. Bool -> Lex a ()
lexWhiteSpace_ Bool
True
            forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Bool
True)
        Char
'\t':String
_ -> do
            forall a. Lex a ()
lexTab
            (Bool
bol', Bool
_) <- forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
bol
            forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
bol', Bool
True)
        Char
c:String
_ | Char -> Bool
isSpace Char
c -> do
            forall r. Int -> Lex r ()
discard Int
1
            (Bool
bol', Bool
_) <- forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
bol
            forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
bol', Bool
True)
        String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
bol, Bool
False)

-- | lexWhiteSpace without the return value.
lexWhiteSpace_ :: Bool -> Lex a ()
lexWhiteSpace_ :: forall a. Bool -> Lex a ()
lexWhiteSpace_ Bool
bol =  do (Bool, Bool)
_ <- forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
bol
                         forall (m :: * -> *) a. Monad m => a -> m a
return ()

isRecognisedPragma, isLinePragma :: String -> Bool
isRecognisedPragma :: String -> Bool
isRecognisedPragma String
str = let pragma :: String
pragma = forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isPragmaChar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ String
str
                          in case String -> Maybe Token
lookupKnownPragma String
pragma of
                              Maybe Token
Nothing -> Bool
False
                              Maybe Token
_       -> Bool
True

isLinePragma :: String -> Bool
isLinePragma String
str = let pragma :: String
pragma = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isAlphaNum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ String
str
                    in case String
pragma of
                        String
"line"  -> Bool
True
                        String
_       -> Bool
False

lexLinePragma :: Lex a (Int, String)
lexLinePragma :: forall a. Lex a (Int, String)
lexLinePragma = do
    forall r. Int -> Lex r ()
discard Int
3   -- {-#
    forall a. (Char -> Bool) -> Lex a ()
lexWhile_ Char -> Bool
isSpace
    forall r. Int -> Lex r ()
discard Int
4   -- LINE
    forall a. (Char -> Bool) -> Lex a ()
lexWhile_ Char -> Bool
isSpace
    String
i <- forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isDigit
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
i) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Improperly formatted LINE pragma"
    forall a. (Char -> Bool) -> Lex a ()
lexWhile_ Char -> Bool
isSpace
    forall a. Char -> String -> Lex a ()
matchChar Char
'"' String
"Improperly formatted LINE pragma"
    String
fn <- forall a. (Char -> Bool) -> Lex a String
lexWhile (forall a. Eq a => a -> a -> Bool
/= Char
'"')
    forall a. Char -> String -> Lex a ()
matchChar Char
'"' String
"Impossible - lexLinePragma"
    forall a. (Char -> Bool) -> Lex a ()
lexWhile_ Char -> Bool
isSpace
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Char -> String -> Lex a ()
matchChar String
"Improperly formatted LINE pragma") String
"#-}"
    forall a. Lex a ()
lexNewline
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Read a => String -> a
read String
i, String
fn)

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

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

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

lexToken :: Lex a Token
lexToken :: forall a. Lex a Token
lexToken = do
    Maybe ExtContext
ec <- forall a. Lex a (Maybe ExtContext)
getExtContext
    -- we don't bother to check XmlSyntax since we couldn't
    -- have ended up in a non-Nothing context if it wasn't
    -- enabled.
    case Maybe ExtContext
ec of
     Just ExtContext
HarpCtxt     -> forall a. Lex a Token
lexHarpToken
     Just ExtContext
TagCtxt      -> forall a. Lex a Token
lexTagCtxt
     Just ExtContext
CloseTagCtxt -> forall a. Lex a Token
lexCloseTagCtxt
     Just ExtContext
ChildCtxt    -> forall a. Lex a Token
lexChildCtxt
     Just ExtContext
CodeTagCtxt  -> forall a. Lex a Token
lexCodeTagCtxt
     Maybe ExtContext
_         -> forall a. Lex a Token
lexStdToken


lexChildCtxt :: Lex a Token
lexChildCtxt :: forall a. Lex a Token
lexChildCtxt = do
    -- if we ever end up here, then XmlSyntax must be on.
    String
s <- forall r. Lex r String
getInput
    case String
s of
        Char
'<':Char
'%':Char
'>':String
_ -> do forall r. Int -> Lex r ()
discard Int
3
                            forall a. ExtContext -> Lex a ()
pushExtContextL ExtContext
ChildCtxt
                            forall (m :: * -> *) a. Monad m => a -> m a
return Token
XChildTagOpen
        Char
'<':Char
'%':String
_ -> do forall r. Int -> Lex r ()
discard Int
2
                        forall a. ExtContext -> Lex a ()
pushExtContextL ExtContext
CodeTagCtxt
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
XCodeTagOpen
        Char
'<':Char
'/':String
_ -> do forall r. Int -> Lex r ()
discard Int
2
                        forall a. String -> Lex a ()
popExtContextL String
"lexChildCtxt"
                        forall a. ExtContext -> Lex a ()
pushExtContextL ExtContext
CloseTagCtxt
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
XCloseTagOpen
        Char
'<':Char
'[':String
_ -> do forall r. Int -> Lex r ()
discard Int
2
                        forall a. ExtContext -> Lex a ()
pushExtContextL ExtContext
HarpCtxt
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
XRPatOpen
        Char
'<':String
_     -> do forall r. Int -> Lex r ()
discard Int
1
                        forall a. ExtContext -> Lex a ()
pushExtContextL ExtContext
TagCtxt
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
XStdTagOpen
        String
_     -> forall a. Lex a Token
lexPCDATA


lexPCDATA :: Lex a Token
lexPCDATA :: forall a. Lex a Token
lexPCDATA = do
    -- if we ever end up here, then XmlSyntax must be on.
    String
s <- forall r. Lex r String
getInput
    case String
s of
        [] -> forall (m :: * -> *) a. Monad m => a -> m a
return Token
EOF
        String
_  -> case String
s of
            Char
'\n':String
_ -> do
                Token
x <- forall a. Lex a ()
lexNewline forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Lex a Token
lexPCDATA
                case Token
x of
                 XPCDATA String
p -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Token
XPCDATA forall a b. (a -> b) -> a -> b
$ Char
'\n'forall a. a -> [a] -> [a]
:String
p
                 Token
EOF -> forall (m :: * -> *) a. Monad m => a -> m a
return Token
EOF
                 Token
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"lexPCDATA: unexpected token: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Token
x
            Char
'<':String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Token
XPCDATA String
""
            String
_ -> do let pcd :: String
pcd = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Char
c -> Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"<\n") String
s
                        l :: Int
l = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pcd
                    forall r. Int -> Lex r ()
discard Int
l
                    Token
x <- forall a. Lex a Token
lexPCDATA
                    case Token
x of
                     XPCDATA String
pcd' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Token
XPCDATA forall a b. (a -> b) -> a -> b
$ String
pcd forall a. [a] -> [a] -> [a]
++ String
pcd'
                     Token
EOF -> forall (m :: * -> *) a. Monad m => a -> m a
return Token
EOF
                     Token
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"lexPCDATA: unexpected token: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Token
x


lexCodeTagCtxt :: Lex a Token
lexCodeTagCtxt :: forall a. Lex a Token
lexCodeTagCtxt = do
    -- if we ever end up here, then XmlSyntax must be on.
    String
s <- forall r. Lex r String
getInput
    case String
s of
        Char
'%':Char
'>':String
_ -> do forall r. Int -> Lex r ()
discard Int
2
                        forall a. String -> Lex a ()
popExtContextL String
"lexCodeTagContext"
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
XCodeTagClose
        String
_     -> forall a. Lex a Token
lexStdToken

lexCloseTagCtxt :: Lex a Token
lexCloseTagCtxt :: forall a. Lex a Token
lexCloseTagCtxt = do
    -- if we ever end up here, then XmlSyntax must be on.
    String
s <- forall r. Lex r String
getInput
    case String
s of
        Char
'%':Char
'>':String
_ -> do forall r. Int -> Lex r ()
discard Int
2
                        forall a. String -> Lex a ()
popExtContextL String
"lexCloseTagCtxt"
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
XCodeTagClose
        Char
'>':String
_     -> do forall r. Int -> Lex r ()
discard Int
1
                        forall a. String -> Lex a ()
popExtContextL String
"lexCloseTagCtxt"
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
XStdTagClose
        String
_     -> forall a. Lex a Token
lexStdToken

lexTagCtxt :: Lex a Token
lexTagCtxt :: forall a. Lex a Token
lexTagCtxt = do
    -- if we ever end up here, then XmlSyntax must be on.
    String
s <- forall r. Lex r String
getInput
    case String
s of
        Char
'/':Char
'>':String
_ -> do forall r. Int -> Lex r ()
discard Int
2
                        forall a. String -> Lex a ()
popExtContextL String
"lexTagCtxt: Empty tag"
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
XEmptyTagClose
        Char
'>':String
_     -> do forall r. Int -> Lex r ()
discard Int
1
                        forall a. String -> Lex a ()
popExtContextL String
"lexTagCtxt: Standard tag"
                        forall a. ExtContext -> Lex a ()
pushExtContextL ExtContext
ChildCtxt
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
XStdTagClose
        String
_     -> forall a. Lex a Token
lexStdToken

lexHarpToken :: Lex a Token
lexHarpToken :: forall a. Lex a Token
lexHarpToken = do
    -- if we ever end up here, then RegularPatterns must be on.
    String
s <- forall r. Lex r String
getInput
    case String
s of
        Char
']':Char
'>':String
_ -> do forall r. Int -> Lex r ()
discard Int
2
                        forall a. String -> Lex a ()
popExtContextL String
"lexHarpToken"
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
XRPatClose
        String
_     -> forall a. Lex a Token
lexStdToken

lexStdToken :: Lex a Token
lexStdToken :: forall a. Lex a Token
lexStdToken = do
    String
s <- forall r. Lex r String
getInput
    [KnownExtension]
exts <- forall a. Lex a [KnownExtension]
getExtensionsL
    let intHash :: Lex a ((Integer, String) -> Token)
intHash = forall b a.
(b -> Token)
-> (b -> Token) -> Either String (b -> Token) -> Lex a (b -> Token)
lexHash (Integer, String) -> Token
IntTok (Integer, String) -> Token
IntTokHash (forall a b. b -> Either a b
Right (Integer, String) -> Token
WordTokHash)
    case String
s of
        [] -> forall (m :: * -> *) a. Monad m => a -> m a
return Token
EOF

        Char
'0':Char
c:Char
d:String
_ | Char -> Char
toLower Char
c forall a. Eq a => a -> a -> Bool
== Char
'o' Bool -> Bool -> Bool
&& Char -> Bool
isOctDigit Char
d -> do
                        forall r. Int -> Lex r ()
discard Int
2
                        (Integer
n, String
str) <- forall a. Lex a (Integer, String)
lexOctal
                        (Integer, String) -> Token
con <- forall {a}. Lex a ((Integer, String) -> Token)
intHash
                        forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer, String) -> Token
con (Integer
n, Char
'0'forall a. a -> [a] -> [a]
:Char
cforall a. a -> [a] -> [a]
:String
str))
                  | Char -> Char
toLower Char
c forall a. Eq a => a -> a -> Bool
== Char
'b' Bool -> Bool -> Bool
&& Char -> Bool
isBinDigit Char
d Bool -> Bool -> Bool
&& KnownExtension
BinaryLiterals forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                        forall r. Int -> Lex r ()
discard Int
2
                        (Integer
n, String
str) <- forall a. Lex a (Integer, String)
lexBinary
                        (Integer, String) -> Token
con <- forall {a}. Lex a ((Integer, String) -> Token)
intHash
                        forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer, String) -> Token
con (Integer
n, Char
'0'forall a. a -> [a] -> [a]
:Char
cforall a. a -> [a] -> [a]
:String
str))
                  | Char -> Char
toLower Char
c forall a. Eq a => a -> a -> Bool
== Char
'x' Bool -> Bool -> Bool
&& Char -> Bool
isHexDigit Char
d -> do
                        forall r. Int -> Lex r ()
discard Int
2
                        (Integer
n, String
str) <- forall a. Lex a (Integer, String)
lexHexadecimal
                        (Integer, String) -> Token
con <- forall {a}. Lex a ((Integer, String) -> Token)
intHash
                        forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer, String) -> Token
con (Integer
n, Char
'0'forall a. a -> [a] -> [a]
:Char
cforall a. a -> [a] -> [a]
:String
str))

        -- implicit parameters
        Char
'?':Char
c:String
_ | Char -> Bool
isIdentStart Char
c Bool -> Bool -> Bool
&& KnownExtension
ImplicitParams forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                        forall r. Int -> Lex r ()
discard Int
1
                        String
id <- forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Token
IDupVarId String
id

        Char
'%':Char
c:String
_ | Char -> Bool
isIdentStart Char
c Bool -> Bool -> Bool
&& KnownExtension
ImplicitParams forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                        forall r. Int -> Lex r ()
discard Int
1
                        String
id <- forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Token
ILinVarId String
id
        -- end implicit parameters

        -- harp
        Char
'(':Char
'|':Char
c:String
_ | KnownExtension
RegularPatterns forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isHSymbol Char
c) ->
                        forall r. Int -> Lex r ()
discard Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Token
RPGuardOpen
                    | KnownExtension
Arrows forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isHSymbol Char
c) ->
                        forall r. Int -> Lex r ()
discard Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Token
OpenArrowBracket
        Char
'|':Char
')':String
_ | KnownExtension
RegularPatterns forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> forall r. Int -> Lex r ()
discard Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Token
RPGuardClose
                  | KnownExtension
Arrows forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> forall r. Int -> Lex r ()
discard Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Token
CloseArrowBracket
        {- This is handled by the reserved_ops above.
        '@':':':_ | RegularPatterns `elem` exts ->
                     do discard 2
                        return RPCAt -}


        -- template haskell
        Char
'[':Char
'|':Char
'|':String
_ | KnownExtension
TemplateHaskell forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                forall r. Int -> Lex r ()
discard Int
3
                forall (m :: * -> *) a. Monad m => a -> m a
return Token
THTExpQuote

        Char
'[':Char
'e':Char
'|':Char
'|':String
_ | KnownExtension
TemplateHaskell forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                forall r. Int -> Lex r ()
discard Int
4
                forall (m :: * -> *) a. Monad m => a -> m a
return Token
THTExpQuote

        Char
'[':Char
'|':String
_ | KnownExtension
TemplateHaskell forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                forall r. Int -> Lex r ()
discard Int
2
                forall (m :: * -> *) a. Monad m => a -> m a
return Token
THExpQuote

        Char
'[':Char
c:Char
'|':String
_ | Char
c forall a. Eq a => a -> a -> Bool
== Char
'e' Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                        forall r. Int -> Lex r ()
discard Int
3
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
THExpQuote
                    | Char
c forall a. Eq a => a -> a -> Bool
== Char
'p' Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                        forall r. Int -> Lex r ()
discard Int
3
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
THPatQuote
                    | Char
c forall a. Eq a => a -> a -> Bool
== Char
'd' Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                        forall r. Int -> Lex r ()
discard Int
3
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
THDecQuote
                    | Char
c forall a. Eq a => a -> a -> Bool
== Char
't' Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                        forall r. Int -> Lex r ()
discard Int
3
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
THTypQuote
        Char
'[':Char
'$':Char
c:String
_ | Char -> Bool
isIdentStart Char
c Bool -> Bool -> Bool
&& KnownExtension
QuasiQuotes forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts ->
                        forall r. Int -> Lex r ()
discard Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Char -> Lex a Token
lexQuasiQuote Char
c

        Char
'[':Char
c:String
s' | Char -> Bool
isIdentStart Char
c Bool -> Bool -> Bool
&& KnownExtension
QuasiQuotes forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts Bool -> Bool -> Bool
&& case forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isIdent String
s' of { Char
'|':String
_ -> Bool
True;String
_->Bool
False} ->
                        forall r. Int -> Lex r ()
discard Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Char -> Lex a Token
lexQuasiQuote Char
c
                 | Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
&& KnownExtension
QuasiQuotes forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts Bool -> Bool -> Bool
&& case forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isPossiblyQvar String
s' of { Char
'|':String
_ -> Bool
True;String
_->Bool
False} ->
                        forall r. Int -> Lex r ()
discard Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Char -> Lex a Token
lexQuasiQuote Char
c

        Char
'|':Char
'|':Char
']':String
_ | KnownExtension
TemplateHaskell forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                        forall r. Int -> Lex r ()
discard Int
3
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
THTCloseQuote
        Char
'|':Char
']':String
_ | KnownExtension
TemplateHaskell forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                        forall r. Int -> Lex r ()
discard Int
2
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
THCloseQuote

        Char
'$':Char
c1:Char
c2:String
_ | Char -> Bool
isIdentStart Char
c1 Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                        forall r. Int -> Lex r ()
discard Int
1
                        String
id <- forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Token
THIdEscape String
id
                    | Char
c1 forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                        forall r. Int -> Lex r ()
discard Int
2
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
THParenEscape
                    | Char
c1 forall a. Eq a => a -> a -> Bool
== Char
'$' Bool -> Bool -> Bool
&& Char -> Bool
isIdentStart Char
c2 Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                        forall r. Int -> Lex r ()
discard Int
2
                        String
id <- forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Token
THTIdEscape String
id
                    | Char
c1 forall a. Eq a => a -> a -> Bool
== Char
'$' Bool -> Bool -> Bool
&& Char
c2 forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                        forall r. Int -> Lex r ()
discard Int
3
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
THTParenEscape
        -- end template haskell

        -- hsx
        Char
'<':Char
'%':Char
c:String
_ | KnownExtension
XmlSyntax forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts ->
                        case Char
c of
                         Char
'>' -> do forall r. Int -> Lex r ()
discard Int
3
                                   forall a. ExtContext -> Lex a ()
pushExtContextL ExtContext
ChildCtxt
                                   forall (m :: * -> *) a. Monad m => a -> m a
return Token
XChildTagOpen
                         Char
_   -> do forall r. Int -> Lex r ()
discard Int
2
                                   forall a. ExtContext -> Lex a ()
pushExtContextL ExtContext
CodeTagCtxt
                                   forall (m :: * -> *) a. Monad m => a -> m a
return Token
XCodeTagOpen
        Char
'<':Char
c:String
_ | Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
&& KnownExtension
XmlSyntax forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                        forall r. Int -> Lex r ()
discard Int
1
                        forall a. ExtContext -> Lex a ()
pushExtContextL ExtContext
TagCtxt
                        forall (m :: * -> *) a. Monad m => a -> m a
return Token
XStdTagOpen
        -- end hsx

        Char
'(':Char
'#':Char
c:String
_ | [KnownExtension] -> Bool
unboxed [KnownExtension]
exts Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isHSymbol Char
c) -> forall r. Int -> Lex r ()
discard Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Token
LeftHashParen

        Char
'#':Char
')':String
_   | [KnownExtension] -> Bool
unboxed [KnownExtension]
exts -> forall r. Int -> Lex r ()
discard Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Token
RightHashParen

        -- pragmas

        Char
'{':Char
'-':Char
'#':String
_ -> forall a. Lex a ()
saveExtensionsL forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall r. Int -> Lex r ()
discard Int
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Lex a Token
lexPragmaStart

        Char
'#':Char
'-':Char
'}':String
_ -> forall a. Lex a ()
restoreExtensionsL forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall r. Int -> Lex r ()
discard Int
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Token
PragmaEnd

        -- Parallel arrays

        Char
'[':Char
':':String
_ | KnownExtension
ParallelArrays forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> forall r. Int -> Lex r ()
discard Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Token
ParArrayLeftSquare

        Char
':':Char
']':String
_ | KnownExtension
ParallelArrays forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> forall r. Int -> Lex r ()
discard Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Token
ParArrayRightSquare

        -- Lexed seperately to deal with visible type applciation

        Char
'@':Char
c:String
_ | KnownExtension
TypeApplications forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts
                   -- Operator starting with an '@'
                   Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isOpSymbol Char
c) -> do
                                                Char
lc <- forall r. Lex r Char
getLastChar
                                                if Char -> Bool
isIdent Char
lc
                                                  then forall r. Int -> Lex r ()
discard Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Token
At
                                                  else forall r. Int -> Lex r ()
discard Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Token
TApp

        Char
'#':Char
c:String
_ | KnownExtension
OverloadedLabels forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts
                   Bool -> Bool -> Bool
&& Char -> Bool
isIdentStart Char
c -> do
                                                  forall r. Int -> Lex r ()
discard Int
1
                                                  [String
ident] <- forall a. Lex a [String]
lexIdents
                                                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Token
LabelVarId String
ident


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

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

            | Char -> Bool
isIdentStart Char
c -> do
                    [String]
idents <- forall a. Lex a [String]
lexIdents
                    case [String]
idents of
                     [String
ident] -> case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
ident ([(String, (Token, Maybe ExtScheme))]
reserved_ids forall a. [a] -> [a] -> [a]
++ [(String, (Token, Maybe ExtScheme))]
special_varids) of
                                 Just (Token
keyword, Maybe ExtScheme
scheme) ->
                                    -- check if an extension keyword is enabled
                                    if forall a. Enabled a => a -> [KnownExtension] -> Bool
isEnabled Maybe ExtScheme
scheme [KnownExtension]
exts
                                     then forall a. Token -> Lex a ()
flagKW Token
keyword forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Token
keyword
                                     else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Token
VarId String
ident
                                 Maybe (Token, Maybe ExtScheme)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Token
VarId String
ident
                     [String]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [String] -> Token
DVarId [String]
idents

            | Char -> Bool
isHSymbol Char
c -> do
                    String
sym <- forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isHSymbol
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
sym ([(String, (Token, Maybe ExtScheme))]
reserved_ops forall a. [a] -> [a] -> [a]
++ [(String, (Token, Maybe ExtScheme))]
special_varops) of
                              Just (Token
t , Maybe ExtScheme
scheme) ->
                                -- check if an extension op is enabled
                                if forall a. Enabled a => a -> [KnownExtension] -> Bool
isEnabled Maybe ExtScheme
scheme [KnownExtension]
exts
                                 then Token
t
                                 else case Char
c of
                                        Char
':' -> String -> Token
ConSym String
sym
                                        Char
_   -> String -> Token
VarSym String
sym
                              Maybe (Token, Maybe ExtScheme)
Nothing -> case Char
c of
                                          Char
':' -> String -> Token
ConSym String
sym
                                          Char
_   -> String -> Token
VarSym String
sym

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

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

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

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

      where lexIdents :: Lex a [String]
            lexIdents :: forall a. Lex a [String]
lexIdents = do
                String
ident <- forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
                String
s <- forall r. Lex r String
getInput
                [KnownExtension]
exts <- forall a. Lex a [KnownExtension]
getExtensionsL
                case String
s of
                 -- This is the only way we can get more than one ident in the list
                 -- and it requires XmlSyntax to be on.
                 Char
'-':Char
c:String
_ | KnownExtension
XmlSyntax forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts Bool -> Bool -> Bool
&& Char -> Bool
isAlpha Char
c -> do
                        forall r. Int -> Lex r ()
discard Int
1
                        [String]
idents <- forall a. Lex a [String]
lexIdents
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
ident forall a. a -> [a] -> [a]
: [String]
idents
                 Char
'#':String
_ | KnownExtension
MagicHash forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                        String
hashes <- forall a. (Char -> Bool) -> Lex a String
lexWhile (forall a. Eq a => a -> a -> Bool
== Char
'#')
                        forall (m :: * -> *) a. Monad m => a -> m a
return [String
ident forall a. [a] -> [a] -> [a]
++ String
hashes]
                 String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return [String
ident]

            lexQuasiQuote :: Char -> Lex a Token
            lexQuasiQuote :: forall a. Char -> Lex a Token
lexQuasiQuote Char
c = do
                -- We've seen and dropped [$ already
                String
ident <- forall r. Lex r String
lexQuoter
                forall a. Char -> String -> Lex a ()
matchChar Char
'|' String
"Malformed quasi-quote quoter"
                String
body <- forall r. Lex r String
lexQQBody
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (String, String) -> Token
THQuasiQuote (String
ident, String
body)
                  where lexQuoter :: Lex a String
lexQuoter
                         | Char -> Bool
isIdentStart Char
c = forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
                         | Bool
otherwise = do
                            Token
qualThing <- forall a. String -> Lex a Token
lexConIdOrQual String
""
                            case Token
qualThing of
                                QVarId (String
s1,String
s2) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
s1 forall a. [a] -> [a] -> [a]
++ Char
'.'forall a. a -> [a] -> [a]
:String
s2
                                QVarSym (String
s1, String
s2) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
s1 forall a. [a] -> [a] -> [a]
++ Char
'.'forall a. a -> [a] -> [a]
:String
s2
                                Token
_                -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Malformed quasi-quote quoter"

            lexQQBody :: Lex a String
            lexQQBody :: forall r. Lex r String
lexQQBody = do
                String
s <- forall r. Lex r String
getInput
                case String
s of
                  Char
'\\':Char
']':String
_ -> do forall r. Int -> Lex r ()
discard Int
2
                                   String
str <- forall r. Lex r String
lexQQBody
                                   forall (m :: * -> *) a. Monad m => a -> m a
return (Char
']'forall a. a -> [a] -> [a]
:String
str)
                  Char
'\\':Char
'|':String
_ -> do forall r. Int -> Lex r ()
discard Int
2
                                   String
str <- forall r. Lex r String
lexQQBody
                                   forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'|'forall a. a -> [a] -> [a]
:String
str)
                  Char
'|':Char
']':String
_  -> forall r. Int -> Lex r ()
discard Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return String
""
                  Char
'|':String
_ -> do forall r. Int -> Lex r ()
discard Int
1
                              String
str <- forall r. Lex r String
lexQQBody
                              forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'|'forall a. a -> [a] -> [a]
:String
str)
                  Char
']':String
_ -> do forall r. Int -> Lex r ()
discard Int
1
                              String
str <- forall r. Lex r String
lexQQBody
                              forall (m :: * -> *) a. Monad m => a -> m a
return (Char
']'forall a. a -> [a] -> [a]
:String
str)
                  Char
'\\':String
_ -> do forall r. Int -> Lex r ()
discard Int
1
                               String
str <- forall r. Lex r String
lexQQBody
                               forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\\'forall a. a -> [a] -> [a]
:String
str)
                  Char
'\n':String
_ -> do forall a. Lex a ()
lexNewline
                               String
str <- forall r. Lex r String
lexQQBody
                               forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\n'forall a. a -> [a] -> [a]
:String
str)
                  []     -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected end of input while lexing quasi-quoter"
                  String
_ -> do String
str <- forall a. (Char -> Bool) -> Lex a String
lexWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"\\|\n"))
                          String
rest <- forall r. Lex r String
lexQQBody
                          forall (m :: * -> *) a. Monad m => a -> m a
return (String
strforall a. [a] -> [a] -> [a]
++String
rest)

unboxed :: [KnownExtension] -> Bool
unboxed :: [KnownExtension] -> Bool
unboxed [KnownExtension]
exts = KnownExtension
UnboxedSums forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts Bool -> Bool -> Bool
|| KnownExtension
UnboxedTuples forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts

-- Underscores are used in some pragmas. Options pragmas are a special case
-- with our representation: the thing after the underscore is a parameter.
-- Strip off the parameters to option pragmas by hand here, everything else
-- sits in the pragmas map.
lookupKnownPragma :: String -> Maybe Token
lookupKnownPragma :: String -> Maybe Token
lookupKnownPragma String
s =
    case forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s of
      String
x | String
"options_" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (Maybe String, String) -> Token
OPTIONS (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
8 String
s, forall a. HasCallStack => a
undefined)
        | String
"options" forall a. Eq a => a -> a -> Bool
== String
x            -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (Maybe String, String) -> Token
OPTIONS (forall a. Maybe a
Nothing, forall a. HasCallStack => a
undefined)
        | Bool
otherwise                 -> forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
x [(String, Token)]
pragmas

lexPragmaStart :: Lex a Token
lexPragmaStart :: forall a. Lex a Token
lexPragmaStart = do
    forall a. (Char -> Bool) -> Lex a ()
lexWhile_ Char -> Bool
isSpace
    String
pr <- forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isPragmaChar
    case String -> Maybe Token
lookupKnownPragma String
pr of
     Just (INLINE Bool
True) -> do
            String
s <- forall r. Lex r String
getInput
            case forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s of
             Char
' ':Char
'c':Char
'o':Char
'n':Char
'l':Char
'i':Char
'k':Char
'e':String
_  -> do
                      forall r. Int -> Lex r ()
discard Int
8
                      forall (m :: * -> *) a. Monad m => a -> m a
return Token
INLINE_CONLIKE
             String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Token
INLINE Bool
True
     Just Token
SPECIALISE -> do
            String
s <- forall r. Lex r String
getInput
            case forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s of
             Char
'i':Char
'n':Char
'l':Char
'i':Char
'n':Char
'e':String
_ -> do
                      forall a. (Char -> Bool) -> Lex a ()
lexWhile_ Char -> Bool
isSpace
                      forall r. Int -> Lex r ()
discard Int
6
                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Token
SPECIALISE_INLINE Bool
True
             Char
'n':Char
'o':Char
'i':Char
'n':Char
'l':Char
'i':Char
'n':Char
'e':String
_ -> do
                        forall a. (Char -> Bool) -> Lex a ()
lexWhile_ Char -> Bool
isSpace
                        forall r. Int -> Lex r ()
discard Int
8
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Token
SPECIALISE_INLINE Bool
False
             Char
'n':Char
'o':Char
't':Char
'i':Char
'n':Char
'l':Char
'i':Char
'n':Char
'e':String
_ -> do
                        forall a. (Char -> Bool) -> Lex a ()
lexWhile_ Char -> Bool
isSpace
                        forall r. Int -> Lex r ()
discard Int
9
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Token
SPECIALISE_INLINE Bool
False
             String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Token
SPECIALISE

     Just (OPTIONS (Maybe String, String)
opt) ->     -- see, I promised we'd mask out the 'undefined'
            -- We do not want to store necessary whitespace in the datatype
            -- but if the pragma starts with a newline then we must keep
            -- it to differentiate the two cases.
            let dropIfSpace :: ShowS
dropIfSpace (Char
' ':String
xs) = String
xs
                dropIfSpace String
xs       = String
xs
             in
              case forall a b. (a, b) -> a
fst (Maybe String, String)
opt of
                Just String
opt' -> do
                  String
rest <- forall r. Lex r String
lexRawPragma
                  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Maybe String, String) -> Token
OPTIONS (forall a. a -> Maybe a
Just String
opt', ShowS
dropIfSpace String
rest)
                Maybe String
Nothing -> do
                  String
s <- forall r. Lex r String
getInput
                  case String
s of
                    Char
x:String
_ | Char -> Bool
isSpace Char
x -> do
                      String
rest <- forall r. Lex r String
lexRawPragma
                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Maybe String, String) -> Token
OPTIONS (forall a. Maybe a
Nothing, ShowS
dropIfSpace String
rest)
                    String
_  -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Malformed Options pragma"
     Just Token
RULES -> do -- Rules enable ScopedTypeVariables locally.
            forall a. KnownExtension -> Lex a ()
addExtensionL KnownExtension
ScopedTypeVariables
            forall (m :: * -> *) a. Monad m => a -> m a
return Token
RULES
{-     Just (CFILES _) -> do
            rest <- lexRawPragma
            return $ CFILES rest
     Just (INCLUDE _) -> do
            rest <- lexRawPragma
            return $ INCLUDE rest -}
     Just Token
p ->  forall (m :: * -> *) a. Monad m => a -> m a
return Token
p

     Maybe Token
_      -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Internal error: Unrecognised recognised pragma"
                  -- do rawStr <- lexRawPragma
                  -- return $ PragmaUnknown (pr, rawStr) -- no support for unrecognized pragmas, treat as comment
                  -- discard 3 -- #-}
                  -- topLexer -- we just discard it as a comment for now and restart -}

lexRawPragma :: Lex a String
lexRawPragma :: forall r. Lex r String
lexRawPragma = forall r. Lex r String
lexRawPragmaAux
 where lexRawPragmaAux :: Lex a String
lexRawPragmaAux = do
        String
rpr <- forall a. (Char -> Bool) -> Lex a String
lexWhile (forall a. Eq a => a -> a -> Bool
/=Char
'#')
        String
s <- forall r. Lex r String
getInput
        case String
s of
         Char
'#':Char
'-':Char
'}':String
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return String
rpr
         String
"" -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"End-of-file inside pragma"
         String
_ -> do
            forall r. Int -> Lex r ()
discard Int
1
            String
rpr' <- forall r. Lex r String
lexRawPragma
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
rpr forall a. [a] -> [a] -> [a]
++ Char
'#'forall a. a -> [a] -> [a]
:String
rpr'

lexDecimalOrFloat :: Lex a Token
lexDecimalOrFloat :: forall a. Lex a Token
lexDecimalOrFloat = do
    String
ds <- forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isDigit
    String
rest <- forall r. Lex r String
getInput
    [KnownExtension]
exts <- forall a. Lex a [KnownExtension]
getExtensionsL
    case String
rest of
        (Char
'.':Char
d:String
_) | Char -> Bool
isDigit Char
d -> do
                forall r. Int -> Lex r ()
discard Int
1
                String
frac <- forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isDigit
                let num :: Integer
num = Integer -> String -> Integer
parseInteger Integer
10 (String
ds forall a. [a] -> [a] -> [a]
++ String
frac)
                    decimals :: Integer
decimals = forall a. Integral a => a -> Integer
toInteger (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
frac)
                (Integer
exponent, String
estr) <- do
                    String
rest2 <- forall r. Lex r String
getInput
                    case String
rest2 of
                        Char
'e':String
_ -> forall a. Lex a (Integer, String)
lexExponent
                        Char
'E':String
_ -> forall a. Lex a (Integer, String)
lexExponent
                        String
_     -> forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
0,String
"")
                (Rational, String) -> Token
con <- forall b a.
(b -> Token)
-> (b -> Token) -> Either String (b -> Token) -> Lex a (b -> Token)
lexHash (Rational, String) -> Token
FloatTok (Rational, String) -> Token
FloatTokHash (forall a b. b -> Either a b
Right (Rational, String) -> Token
DoubleTokHash)
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Rational, String) -> Token
con ((Integer
numforall a. Integral a => a -> a -> Ratio a
%Integer
1) forall a. Num a => a -> a -> a
* Rational
10forall a b. (Fractional a, Integral b) => a -> b -> a
^^(Integer
exponent forall a. Num a => a -> a -> a
- Integer
decimals), String
ds forall a. [a] -> [a] -> [a]
++ Char
'.'forall a. a -> [a] -> [a]
:String
frac forall a. [a] -> [a] -> [a]
++ String
estr)
        Char
e:String
_ | Char -> Char
toLower Char
e forall a. Eq a => a -> a -> Bool
== Char
'e' -> do
                (Integer
exponent, String
estr) <- forall a. Lex a (Integer, String)
lexExponent
                (Rational, String) -> Token
con <- forall b a.
(b -> Token)
-> (b -> Token) -> Either String (b -> Token) -> Lex a (b -> Token)
lexHash (Rational, String) -> Token
FloatTok (Rational, String) -> Token
FloatTokHash (forall a b. b -> Either a b
Right (Rational, String) -> Token
DoubleTokHash)
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Rational, String) -> Token
con ((Integer -> String -> Integer
parseInteger Integer
10 String
dsforall a. Integral a => a -> a -> Ratio a
%Integer
1) forall a. Num a => a -> a -> a
* Rational
10forall a b. (Fractional a, Integral b) => a -> b -> a
^^Integer
exponent, String
ds forall a. [a] -> [a] -> [a]
++ String
estr)
        Char
'#':Char
'#':String
_ | KnownExtension
MagicHash forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> forall r. Int -> Lex r ()
discard Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer, String) -> Token
WordTokHash (Integer -> String -> Integer
parseInteger Integer
10 String
ds, String
ds))
        Char
'#':String
_     | KnownExtension
MagicHash forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> forall r. Int -> Lex r ()
discard Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer, String) -> Token
IntTokHash  (Integer -> String -> Integer
parseInteger Integer
10 String
ds, String
ds))
        String
_         ->              forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer, String) -> Token
IntTok      (Integer -> String -> Integer
parseInteger Integer
10 String
ds, String
ds))

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

lexHash :: (b -> Token) -> (b -> Token) -> Either String (b -> Token) -> Lex a (b -> Token)
lexHash :: forall b a.
(b -> Token)
-> (b -> Token) -> Either String (b -> Token) -> Lex a (b -> Token)
lexHash b -> Token
a b -> Token
b Either String (b -> Token)
c = do
    [KnownExtension]
exts <- forall a. Lex a [KnownExtension]
getExtensionsL
    if KnownExtension
MagicHash forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts
     then do
        String
r <- forall r. Lex r String
getInput
        case String
r of
         Char
'#':Char
'#':String
_ -> case Either String (b -> Token)
c of
                       Right b -> Token
c' -> forall r. Int -> Lex r ()
discard Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return b -> Token
c'
                       Left String
s  -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
s
         Char
'#':String
_     -> forall r. Int -> Lex r ()
discard Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return b -> Token
b
         String
_         ->              forall (m :: * -> *) a. Monad m => a -> m a
return b -> Token
a
     else forall (m :: * -> *) a. Monad m => a -> m a
return b -> Token
a

lexConIdOrQual :: String -> Lex a Token
lexConIdOrQual :: forall a. String -> Lex a Token
lexConIdOrQual String
qual = do
        String
con <- forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
        let conid :: Token
conid | 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' | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
qual = String
con
                  | Bool
otherwise = String
qual forall a. [a] -> [a] -> [a]
++ Char
'.'forall a. a -> [a] -> [a]
:String
con
        Lex a Token
just_a_conid <- forall a v. Lex a v -> Lex a (Lex a v)
alternative (forall (m :: * -> *) a. Monad m => a -> m a
return Token
conid)
        String
rest <- forall r. Lex r String
getInput
        [KnownExtension]
exts <- forall a. Lex a [KnownExtension]
getExtensionsL
        case String
rest of
          Char
'.':Char
c:String
_
             | Char -> Bool
isIdentStart Char
c -> do  -- qualified varid?
                    forall r. Int -> Lex r ()
discard Int
1
                    String
ident <- forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
                    String
s <- forall r. Lex r String
getInput
                    [KnownExtension]
exts' <- forall a. Lex a [KnownExtension]
getExtensionsL
                    String
ident' <- case String
s of
                               Char
'#':String
_ | KnownExtension
MagicHash forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts' -> forall r. Int -> Lex r ()
discard Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (String
ident forall a. [a] -> [a] -> [a]
++ String
"#")
                               String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return String
ident
                    case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
ident' [(String, (Token, Maybe ExtScheme))]
reserved_ids of
                       -- cannot qualify a reserved word
                       Just (Token
_,Maybe ExtScheme
scheme) | forall a. Enabled a => a -> [KnownExtension] -> Bool
isEnabled Maybe ExtScheme
scheme [KnownExtension]
exts'  -> Lex a Token
just_a_conid
                       Maybe (Token, Maybe ExtScheme)
_ -> 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?
                    forall r. Int -> Lex r ()
discard Int
1
                    forall a. String -> Lex a Token
lexConIdOrQual String
qual'

             | Char -> Bool
isHSymbol Char
c -> do    -- qualified symbol?
                    forall r. Int -> Lex r ()
discard Int
1
                    String
sym <- forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isHSymbol
                    [KnownExtension]
exts' <- forall a. Lex a [KnownExtension]
getExtensionsL
                    case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
sym [(String, (Token, Maybe ExtScheme))]
reserved_ops of
                        -- cannot qualify a reserved operator
                        Just (Token
_,Maybe ExtScheme
scheme) | forall a. Enabled a => a -> [KnownExtension] -> Bool
isEnabled Maybe ExtScheme
scheme [KnownExtension]
exts' -> Lex a Token
just_a_conid
                        Maybe (Token, Maybe ExtScheme)
_        -> forall (m :: * -> *) a. Monad m => a -> m a
return 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)

          Char
'#':String
cs
            | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
cs Bool -> Bool -> Bool
||
              Bool -> Bool
not (Char -> Bool
isHSymbol forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head String
cs) Bool -> Bool -> Bool
&&
              Bool -> Bool
not (Char -> Bool
isIdent forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head String
cs) Bool -> Bool -> Bool
&& KnownExtension
MagicHash forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                forall r. Int -> Lex r ()
discard Int
1
                case Token
conid of
                 ConId String
con' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Token
ConId forall a b. (a -> b) -> a -> b
$ String
con' forall a. [a] -> [a] -> [a]
++ String
"#"
                 QConId (String
q,String
con') -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (String, String) -> Token
QConId (String
q,String
con' forall a. [a] -> [a] -> [a]
++ String
"#")
                 Token
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"lexConIdOrQual: unexpected token: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Token
conid
          String
_ ->  forall (m :: * -> *) a. Monad m => a -> m a
return Token
conid -- not a qualified thing

lexCharacter :: Lex a Token
lexCharacter :: forall a. Lex a Token
lexCharacter = do   -- We need to keep track of not only character constants but also TH 'x and ''T
        -- We've seen ' so far
        String
s <- forall r. Lex r String
getInput
        [KnownExtension]
exts <- forall a. Lex a [KnownExtension]
getExtensionsL
        case String
s of
         Char
'\'':String
_ | KnownExtension
TemplateHaskell forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> forall r. Int -> Lex r ()
discard Int
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Token
THTyQuote
         Char
'\\':String
_ -> do
                    (Char
c,String
raw) <- forall a. Lex a (Char, String)
lexEscape
                    forall a. Lex a ()
matchQuote
                    (Char, String) -> Token
con <- forall b a.
(b -> Token)
-> (b -> Token) -> Either String (b -> Token) -> Lex a (b -> Token)
lexHash (Char, String) -> Token
Character (Char, String) -> Token
CharacterHash
                            (forall a b. a -> Either a b
Left String
"Double hash not available for character literals")
                    forall (m :: * -> *) a. Monad m => a -> m a
return ((Char, String) -> Token
con (Char
c, Char
'\\'forall a. a -> [a] -> [a]
:String
raw))
         Char
c:Char
'\'':String
_ -> do
                    forall r. Int -> Lex r ()
discard Int
2
                    (Char, String) -> Token
con <- forall b a.
(b -> Token)
-> (b -> Token) -> Either String (b -> Token) -> Lex a (b -> Token)
lexHash (Char, String) -> Token
Character (Char, String) -> Token
CharacterHash
                            (forall a b. a -> Either a b
Left String
"Double hash not available for character literals")
                    forall (m :: * -> *) a. Monad m => a -> m a
return ((Char, String) -> Token
con (Char
c, [Char
c]))
         String
_ | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts) [KnownExtension
TemplateHaskell, KnownExtension
DataKinds] -> forall (m :: * -> *) a. Monad m => a -> m a
return Token
THVarQuote
         String
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Improper character constant or misplaced \'"

    where matchQuote :: Lex a ()
matchQuote = forall a. Char -> String -> Lex a ()
matchChar Char
'\'' String
"Improperly terminated character constant"


lexString :: Lex a Token
lexString :: forall a. Lex a Token
lexString = forall {r}. (String, String) -> Lex r Token
loop (String
"",String
"")
    where
    loop :: (String, String) -> Lex r Token
loop (String
s,String
raw) = do
        String
r <- forall r. Lex r String
getInput
        [KnownExtension]
exts <- forall a. Lex a [KnownExtension]
getExtensionsL
        case String
r of
            Char
'\\':Char
'&':String
_ -> do
                    forall r. Int -> Lex r ()
discard Int
2
                    (String, String) -> Lex r Token
loop (String
s, Char
'&'forall a. a -> [a] -> [a]
:Char
'\\'forall a. a -> [a] -> [a]
:String
raw)
            Char
'\\':Char
c:String
_ | Char -> Bool
isSpace Char
c -> do
                        forall r. Int -> Lex r ()
discard Int
1
                        String
wcs <- forall r. Lex r String
lexWhiteChars
                        forall a. Char -> String -> Lex a ()
matchChar Char
'\\' String
"Illegal character in string gap"
                        (String, String) -> Lex r Token
loop (String
s, Char
'\\'forall a. a -> [a] -> [a]
:forall a. [a] -> [a]
reverse String
wcs forall a. [a] -> [a] -> [a]
++ Char
'\\'forall a. a -> [a] -> [a]
:String
raw)
                     | Bool
otherwise -> do
                        (Char
ce, String
str) <- forall a. Lex a (Char, String)
lexEscape
                        (String, String) -> Lex r Token
loop (Char
ceforall a. a -> [a] -> [a]
:String
s, forall a. [a] -> [a]
reverse String
str forall a. [a] -> [a] -> [a]
++ Char
'\\'forall a. a -> [a] -> [a]
:String
raw)
            Char
'"':Char
'#':String
_ | KnownExtension
MagicHash forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                        forall r. Int -> Lex r ()
discard Int
2
                        forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> Token
StringHash (forall a. [a] -> [a]
reverse String
s, forall a. [a] -> [a]
reverse String
raw))
            Char
'"':String
_ -> do
                forall r. Int -> Lex r ()
discard Int
1
                forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> Token
StringTok (forall a. [a] -> [a]
reverse String
s, forall a. [a] -> [a]
reverse String
raw))
            Char
c:String
_ | Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\n' -> do
                forall r. Int -> Lex r ()
discard Int
1
                (String, String) -> Lex r Token
loop (Char
cforall a. a -> [a] -> [a]
:String
s, Char
cforall a. a -> [a] -> [a]
:String
raw)
            String
_ ->   forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Improperly terminated string"

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

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

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

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

-- Production ascii from section B.2

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

-- Escaped numbers

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

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

    where
    checkChar :: Integer -> m Char
checkChar Integer
n | Integer
n forall a. Ord a => a -> a -> Bool
<= Integer
0x10FFFF = forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr (forall a. Num a => Integer -> a
fromInteger Integer
n))
    checkChar Integer
_                 = 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, String)
    cntrl :: forall a. Char -> Lex a (Char, String)
cntrl Char
c | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'@' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'_' = forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr (Char -> Int
ord Char
c forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'@'), Char
'^'forall a. a -> [a] -> [a]
:Char
cforall a. a -> [a] -> [a]
:[])
    cntrl Char
_                        = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal control character"

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

-- assumes at least one binary digit
lexBinary :: Lex a (Integer, String)
lexBinary :: forall a. Lex a (Integer, String)
lexBinary = do
    String
ds <- forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isBinDigit
    forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> String -> Integer
parseInteger Integer
2 String
ds, String
ds)

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

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

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

flagKW :: Token -> Lex a ()
flagKW :: forall a. Token -> Lex a ()
flagKW Token
t =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Token
t forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Token
KW_Do, Token
KW_MDo]) forall a b. (a -> b) -> a -> b
$ do
       [KnownExtension]
exts <- forall a. Lex a [KnownExtension]
getExtensionsL
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KnownExtension
NondecreasingIndentation forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts) forall a. Lex a ()
flagDo

-- | Selects ASCII binary digits, i.e. @\'0\'@..@\'1\'@.
isBinDigit :: Char -> Bool
isBinDigit :: Char -> Bool
isBinDigit Char
c =  Char
c forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'1'
------------------------------------------------------------------
-- "Pretty" printing for tokens

showToken :: Token -> String
showToken :: Token -> String
showToken Token
t = case Token
t of
  VarId String
s           -> String
s
  LabelVarId String
s      -> Char
'#'forall a. a -> [a] -> [a]
:String
s
  QVarId (String
q,String
s)      -> String
q forall a. [a] -> [a] -> [a]
++ Char
'.'forall a. a -> [a] -> [a]
:String
s
  IDupVarId String
s       -> Char
'?'forall a. a -> [a] -> [a]
:String
s
  ILinVarId String
s       -> Char
'%'forall a. a -> [a] -> [a]
:String
s
  ConId String
s           -> String
s
  QConId (String
q,String
s)      -> String
q forall a. [a] -> [a] -> [a]
++ Char
'.'forall a. a -> [a] -> [a]
:String
s
  DVarId [String]
ss         -> forall a. [a] -> [[a]] -> [a]
intercalate String
"-" [String]
ss
  VarSym String
s          -> String
s
  ConSym String
s          -> String
s
  QVarSym (String
q,String
s)     -> String
q forall a. [a] -> [a] -> [a]
++ Char
'.'forall a. a -> [a] -> [a]
:String
s
  QConSym (String
q,String
s)     -> String
q forall a. [a] -> [a] -> [a]
++ Char
'.'forall a. a -> [a] -> [a]
:String
s
  IntTok (Integer
_, String
s)         -> String
s
  FloatTok (Rational
_, String
s)       -> String
s
  Character (Char
_, String
s)      -> Char
'\''forall a. a -> [a] -> [a]
:String
s forall a. [a] -> [a] -> [a]
++ String
"'"
  StringTok (String
_, String
s)      -> Char
'"'forall a. a -> [a] -> [a]
:String
s forall a. [a] -> [a] -> [a]
++ String
"\""
  IntTokHash (Integer
_, String
s)     -> String
s forall a. [a] -> [a] -> [a]
++ String
"#"
  WordTokHash (Integer
_, String
s)    -> String
s forall a. [a] -> [a] -> [a]
++ String
"##"
  FloatTokHash (Rational
_, String
s)   -> String
s forall a. [a] -> [a] -> [a]
++ String
"#"
  DoubleTokHash (Rational
_, String
s)  -> String
s forall a. [a] -> [a] -> [a]
++ String
"##"
  CharacterHash (Char
_, String
s)  -> Char
'\''forall a. a -> [a] -> [a]
:String
s forall a. [a] -> [a] -> [a]
++ String
"'#"
  StringHash (String
_, String
s)     -> Char
'"'forall a. a -> [a] -> [a]
:String
s forall a. [a] -> [a] -> [a]
++ String
"\"#"
  Token
LeftParen         -> String
"("
  Token
RightParen        -> String
")"
  Token
LeftHashParen     -> String
"(#"
  Token
RightHashParen    -> String
"#)"
  Token
SemiColon         -> String
";"
  Token
LeftCurly         -> String
"{"
  Token
RightCurly        -> String
"}"
  Token
VRightCurly       -> String
"virtual }"
  Token
LeftSquare        -> String
"["
  Token
RightSquare       -> String
"]"
  Token
ParArrayLeftSquare -> String
"[:"
  Token
ParArrayRightSquare -> String
":]"
  Token
Comma             -> String
","
  Token
Underscore        -> String
"_"
  Token
BackQuote         -> String
"`"
  Token
QuoteColon        -> String
"':"
  Token
Dot               -> 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
TApp              -> String
"@"
  Token
Tilde             -> String
"~"
  Token
DoubleArrow       -> String
"=>"
  Token
Minus             -> String
"-"
  Token
Exclamation       -> String
"!"
  Token
Star              -> String
"*"
  Token
LeftArrowTail     -> String
"-<"
  Token
RightArrowTail    -> String
">-"
  Token
LeftDblArrowTail  -> String
"-<<"
  Token
RightDblArrowTail -> String
">>-"
  Token
OpenArrowBracket  -> String
"(|"
  Token
CloseArrowBracket -> String
"|)"
  Token
THExpQuote        -> String
"[|"
  Token
THTExpQuote       -> String
"[||"
  Token
THPatQuote        -> String
"[p|"
  Token
THDecQuote        -> String
"[d|"
  Token
THTypQuote        -> String
"[t|"
  Token
THCloseQuote      -> String
"|]"
  Token
THTCloseQuote     -> String
"||]"
  THIdEscape String
s      -> Char
'$'forall a. a -> [a] -> [a]
:String
s
  Token
THParenEscape     -> String
"$("
  THTIdEscape String
s     -> String
"$$" forall a. [a] -> [a] -> [a]
++ String
s
  Token
THTParenEscape    -> String
"$$("
  Token
THVarQuote        -> String
"'"
  Token
THTyQuote         -> String
"''"
  THQuasiQuote (String
n,String
q) -> String
"[$" forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
"|" forall a. [a] -> [a] -> [a]
++ String
q forall a. [a] -> [a] -> [a]
++ String
"]"
  Token
RPGuardOpen       -> String
"(|"
  Token
RPGuardClose      -> String
"|)"
  Token
RPCAt             -> String
"@:"
  Token
XCodeTagOpen      -> String
"<%"
  Token
XCodeTagClose     -> String
"%>"
  Token
XStdTagOpen       -> String
"<"
  Token
XStdTagClose      -> String
">"
  Token
XCloseTagOpen     -> String
"</"
  Token
XEmptyTagClose    -> String
"/>"
  XPCDATA String
s         -> String
"PCDATA " forall a. [a] -> [a] -> [a]
++ String
s
  Token
XRPatOpen         -> String
"<["
  Token
XRPatClose        -> String
"]>"
  Token
PragmaEnd         -> String
"#-}"
  Token
RULES             -> String
"{-# RULES"
  INLINE Bool
b          -> String
"{-# " forall a. [a] -> [a] -> [a]
++ if Bool
b then String
"INLINE" else String
"NOINLINE"
  Token
INLINE_CONLIKE    -> String
"{-# " forall a. [a] -> [a] -> [a]
++ String
"INLINE CONLIKE"
  Token
SPECIALISE        -> String
"{-# SPECIALISE"
  SPECIALISE_INLINE Bool
b -> String
"{-# SPECIALISE " forall a. [a] -> [a] -> [a]
++ if Bool
b then String
"INLINE" else String
"NOINLINE"
  Token
SOURCE            -> String
"{-# SOURCE"
  Token
DEPRECATED        -> String
"{-# DEPRECATED"
  Token
WARNING           -> String
"{-# WARNING"
  Token
SCC               -> String
"{-# SCC"
  Token
GENERATED         -> String
"{-# GENERATED"
  Token
CORE              -> String
"{-# CORE"
  Token
UNPACK            -> String
"{-# UNPACK"
  Token
NOUNPACK          -> String
"{-# NOUNPACK"
  OPTIONS (Maybe String
mt,String
_)    -> String
"{-# OPTIONS" forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (Char
':'forall a. a -> [a] -> [a]
:) Maybe String
mt forall a. [a] -> [a] -> [a]
++ String
" ..."
--  CFILES  s         -> "{-# CFILES ..."
--  INCLUDE s         -> "{-# INCLUDE ..."
  Token
LANGUAGE          -> String
"{-# LANGUAGE"
  Token
ANN               -> String
"{-# ANN"
  Token
MINIMAL           -> String
"{-# MINIMAL"
  Token
NO_OVERLAP        -> String
"{-# NO_OVERLAP"
  Token
OVERLAP           -> String
"{-# OVERLAP"
  Token
OVERLAPPING       -> String
"{-# OVERLAPPING"
  Token
OVERLAPPABLE      -> String
"{-# OVERLAPPABLE"
  Token
OVERLAPS          -> String
"{-# OVERLAPS"
  Token
INCOHERENT        -> String
"{-# INCOHERENT"
  Token
COMPLETE          -> String
"{-# COMPLETE"
  Token
KW_As         -> String
"as"
  Token
KW_By         -> String
"by"
  Token
KW_Case       -> String
"case"
  Token
KW_Class      -> String
"class"
  Token
KW_Data       -> String
"data"
  Token
KW_Default    -> String
"default"
  Token
KW_Deriving   -> String
"deriving"
  Token
KW_Do         -> String
"do"
  Token
KW_MDo        -> String
"mdo"
  Token
KW_Else       -> String
"else"
  Token
KW_Family     -> String
"family"
  Token
KW_Forall     -> String
"forall"
  Token
KW_Group      -> String
"group"
  Token
KW_Hiding     -> String
"hiding"
  Token
KW_If         -> String
"if"
  Token
KW_Import     -> String
"import"
  Token
KW_In         -> String
"in"
  Token
KW_Infix      -> String
"infix"
  Token
KW_InfixL     -> String
"infixl"
  Token
KW_InfixR     -> String
"infixr"
  Token
KW_Instance   -> String
"instance"
  Token
KW_Let        -> String
"let"
  Token
KW_Module     -> String
"module"
  Token
KW_NewType    -> String
"newtype"
  Token
KW_Of         -> String
"of"
  Token
KW_Proc       -> String
"proc"
  Token
KW_Rec        -> String
"rec"
  Token
KW_Then       -> String
"then"
  Token
KW_Type       -> String
"type"
  Token
KW_Using      -> String
"using"
  Token
KW_Where      -> String
"where"
  Token
KW_Qualified  -> String
"qualified"
  Token
KW_Foreign    -> String
"foreign"
  Token
KW_Export     -> String
"export"
  Token
KW_Safe       -> String
"safe"
  Token
KW_Unsafe     -> String
"unsafe"
  Token
KW_Threadsafe -> String
"threadsafe"
  Token
KW_Interruptible -> String
"interruptible"
  Token
KW_StdCall    -> String
"stdcall"
  Token
KW_CCall      -> String
"ccall"
  Token
XChildTagOpen -> String
"<%>"
  Token
KW_CPlusPlus  -> String
"cplusplus"
  Token
KW_DotNet     -> String
"dotnet"
  Token
KW_Jvm        -> String
"jvm"
  Token
KW_Js         -> String
"js"
  Token
KW_JavaScript -> String
"javascript"
  Token
KW_CApi       -> String
"capi"
  Token
KW_Role       -> String
"role"
  Token
KW_Pattern    -> String
"pattern"
  Token
KW_Stock      -> String
"stock"
  Token
KW_Anyclass   -> String
"anyclass"
  Token
KW_Via        -> String
"via"

  Token
EOF           -> String
"EOF"