{-# 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
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq,Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show)

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

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

-- FFI
 ( "foreign",   (Token
KW_Foreign,    ExtScheme -> Maybe ExtScheme
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 = [
 ( "as",        (Token
KW_As,         Maybe ExtScheme
forall a. Maybe a
Nothing) ),
 ( "qualified", (Token
KW_Qualified,  Maybe ExtScheme
forall a. Maybe a
Nothing) ),
 ( "hiding",    (Token
KW_Hiding,     Maybe ExtScheme
forall a. Maybe a
Nothing) ),

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

pragmas :: [(String,Token)]
pragmas :: [(String, Token)]
pragmas = [
 ( "rules",             Token
RULES           ),
 ( "inline",            Bool -> Token
INLINE Bool
True     ),
 ( "noinline",          Bool -> Token
INLINE Bool
False    ),
 ( "notinline",         Bool -> Token
INLINE Bool
False    ),
 ( "specialise",        Token
SPECIALISE      ),
 ( "specialize",        Token
SPECIALISE      ),
 ( "source",            Token
SOURCE          ),
 ( "deprecated",        Token
DEPRECATED      ),
 ( "warning",           Token
WARNING         ),
 ( "ann",               Token
ANN             ),
 ( "scc",               Token
SCC             ),
 ( "generated",         Token
GENERATED       ),
 ( "core",              Token
CORE            ),
 ( "unpack",            Token
UNPACK          ),
 ( "nounpack",          Token
NOUNPACK        ),
 ( "language",          Token
LANGUAGE        ),
 ( "minimal",           Token
MINIMAL         ),
 ( "no_overlap",        Token
NO_OVERLAP      ),
 ( "overlap",           Token
OVERLAP         ),
 ( "overlaps",          Token
OVERLAPS        ),
 ( "overlapping",       Token
OVERLAPPING     ),
 ( "overlappable",      Token
OVERLAPPABLE    ),
 ( "incoherent",        Token
INCOHERENT      ),
 ( "complete",          Token
COMPLETE      ),
 ( "options",           (Maybe String, String) -> Token
OPTIONS (Maybe String, String)
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   c :: Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\'' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_'

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

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

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


-- 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 c :: Char
c = Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` "!#$%&*+./<=>?@\\^|-~"

-- | 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 c :: Char
c = Char -> Bool
isIdent (Char -> Char
toLower Char
c) Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.'

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

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

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

topLexer :: Lex a (Loc Token)
topLexer :: Lex a (Loc Token)
topLexer = do
    Bool
b <- Lex a Bool
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
              Lex a ()
forall a. Lex a ()
setBOL Lex a () -> Lex a SrcLoc -> Lex a SrcLoc
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Lex a SrcLoc
forall a. Lex a SrcLoc
getSrcLocL Lex a SrcLoc -> (SrcLoc -> Lex a (Loc Token)) -> Lex a (Loc Token)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \l :: SrcLoc
l -> Loc Token -> Lex a (Loc Token)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> Token -> Loc Token
forall a. SrcSpan -> a -> Loc a
Loc (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
l SrcLoc
l) Token
VRightCurly)
     else do
        Bool
bol <- Lex a Bool
forall a. Lex a Bool
checkBOL
        (bol' :: Bool
bol', ws :: Bool
ws) <- Bool -> Lex a (Bool, Bool)
forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
bol
        -- take care of whitespace in PCDATA
        Maybe ExtContext
ec <- Lex a (Maybe ExtContext)
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 ChildCtxt | Bool -> Bool
not Bool
bol' Bool -> Bool -> Bool
&& Bool
ws -> Lex a SrcLoc
forall a. Lex a SrcLoc
getSrcLocL Lex a SrcLoc -> (SrcLoc -> Lex a (Loc Token)) -> Lex a (Loc Token)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \l :: SrcLoc
l -> Loc Token -> Lex a (Loc Token)
forall (m :: * -> *) a. Monad m => a -> m a
return (Loc Token -> Lex a (Loc Token)) -> Loc Token -> Lex a (Loc Token)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Token -> Loc Token
forall a. SrcSpan -> a -> Loc a
Loc (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
l SrcLoc
l) (Token -> Loc Token) -> Token -> Loc Token
forall a b. (a -> b) -> a -> b
$ String -> Token
XPCDATA " "
         _ -> do Lex a ()
forall a. Lex a ()
startToken
                 SrcLoc
sl <- Lex a SrcLoc
forall a. Lex a SrcLoc
getSrcLocL
                 Token
t <- if Bool
bol' then Lex a Token
forall a. Lex a Token
lexBOL    -- >>= \t -> trace ("BOL: " ++ show t) (return t)
                              else Lex a Token
forall a. Lex a Token
lexToken  -- >>= \t -> trace (show t) (return t)
                 SrcLoc
el <- Lex a SrcLoc
forall a. Lex a SrcLoc
getSrcLocL
                 Loc Token -> Lex a (Loc Token)
forall (m :: * -> *) a. Monad m => a -> m a
return (Loc Token -> Lex a (Loc Token)) -> Loc Token -> Lex a (Loc Token)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Token -> Loc Token
forall a. SrcSpan -> a -> Loc a
Loc (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
sl SrcLoc
el) Token
t

lexWhiteSpace :: Bool -> Lex a (Bool, Bool)
lexWhiteSpace :: Bool -> Lex a (Bool, Bool)
lexWhiteSpace bol :: Bool
bol = do
    String
s <- Lex a String
forall r. Lex r String
getInput
    Bool
ignL <- Lex a Bool
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.
        '{':'-':'#':rest :: String
rest | String -> Bool
isRecognisedPragma String
rest -> (Bool, Bool) -> Lex a (Bool, Bool)
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
                            (l :: Int
l, fn :: String
fn) <- Lex a (Int, String)
forall a. Lex a (Int, String)
lexLinePragma
                            Int -> Lex a ()
forall r. Int -> Lex r ()
setSrcLineL Int
l
                            String -> Lex a ()
forall a. String -> Lex a ()
setLineFilenameL String
fn
                            Bool -> Lex a (Bool, Bool)
forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
True
        '{':'-':_ -> do
            SrcLoc
loc <- Lex a SrcLoc
forall a. Lex a SrcLoc
getSrcLocL
            Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2
            (bol1 :: Bool
bol1, c :: String
c) <- Bool -> String -> Lex a (Bool, String)
forall a. Bool -> String -> Lex a (Bool, String)
lexNestedComment Bool
bol ""
            SrcLoc
loc2 <- Lex a SrcLoc
forall a. Lex a SrcLoc
getSrcLocL
            Comment -> Lex a ()
forall a. Comment -> Lex a ()
pushComment (Comment -> Lex a ()) -> Comment -> Lex a ()
forall a b. (a -> b) -> a -> b
$ Bool -> SrcSpan -> String -> Comment
Comment Bool
True (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
loc SrcLoc
loc2) (ShowS
forall a. [a] -> [a]
reverse String
c)
            (bol2 :: Bool
bol2, _) <- Bool -> Lex a (Bool, Bool)
forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
bol1
            (Bool, Bool) -> Lex a (Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
bol2, Bool
True)
        '-':'-':s1 :: String
s1 | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-') ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isHSymbol String
s1) -> do
            SrcLoc
loc    <- Lex a SrcLoc
forall a. Lex a SrcLoc
getSrcLocL
            Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2
            String
dashes <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-')
            String
rest   <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\n')
            String
s' <- Lex a String
forall r. Lex r String
getInput
            SrcLoc
loc2 <- Lex a SrcLoc
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) (String -> Comment) -> String -> Comment
forall a b. (a -> b) -> a -> b
$ String
dashes String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
rest
            case String
s' of
                [] -> Comment -> Lex a ()
forall a. Comment -> Lex a ()
pushComment Comment
com Lex a () -> Lex a (Bool, Bool) -> Lex a (Bool, Bool)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Bool, Bool) -> Lex a (Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Bool
True)
                _ -> do
                    Comment -> Lex a ()
forall a. Comment -> Lex a ()
pushComment Comment
com
                    Lex a ()
forall a. Lex a ()
lexNewline
                    Bool -> Lex a ()
forall a. Bool -> Lex a ()
lexWhiteSpace_ Bool
True
                    (Bool, Bool) -> Lex a (Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Bool
True)
        '\n':_ -> do
            Lex a ()
forall a. Lex a ()
lexNewline
            Bool -> Lex a ()
forall a. Bool -> Lex a ()
lexWhiteSpace_ Bool
True
            (Bool, Bool) -> Lex a (Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Bool
True)
        '\t':_ -> do
            Lex a ()
forall a. Lex a ()
lexTab
            (bol' :: Bool
bol', _) <- Bool -> Lex a (Bool, Bool)
forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
bol
            (Bool, Bool) -> Lex a (Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
bol', Bool
True)
        c :: Char
c:_ | Char -> Bool
isSpace Char
c -> do
            Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
            (bol' :: Bool
bol', _) <- Bool -> Lex a (Bool, Bool)
forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
bol
            (Bool, Bool) -> Lex a (Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
bol', Bool
True)
        _ -> (Bool, Bool) -> Lex a (Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
bol, Bool
False)

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

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

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

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

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

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

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

lexToken :: Lex a Token
lexToken :: Lex a Token
lexToken = do
    Maybe ExtContext
ec <- Lex a (Maybe ExtContext)
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 HarpCtxt     -> Lex a Token
forall a. Lex a Token
lexHarpToken
     Just TagCtxt      -> Lex a Token
forall a. Lex a Token
lexTagCtxt
     Just CloseTagCtxt -> Lex a Token
forall a. Lex a Token
lexCloseTagCtxt
     Just ChildCtxt    -> Lex a Token
forall a. Lex a Token
lexChildCtxt
     Just CodeTagCtxt  -> Lex a Token
forall a. Lex a Token
lexCodeTagCtxt
     _         -> Lex a Token
forall a. Lex a Token
lexStdToken


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


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


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

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

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

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

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

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

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

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

        -- harp
        '(':'|':c :: Char
c:_ | KnownExtension
RegularPatterns KnownExtension -> [KnownExtension] -> Bool
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) ->
                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RPGuardOpen
                    | KnownExtension
Arrows KnownExtension -> [KnownExtension] -> Bool
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) ->
                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
OpenArrowBracket
        '|':')':_ | KnownExtension
RegularPatterns KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RPGuardClose
                  | KnownExtension
Arrows KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
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
        '[':'|':'|':_ | KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                Int -> Lex a ()
forall r. Int -> Lex r ()
discard 3
                Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THTExpQuote

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

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

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

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

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

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

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

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

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

        -- pragmas

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

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

        -- Parallel arrays

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

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

        -- Lexed seperately to deal with visible type applciation

        '@':c :: Char
c:_ | KnownExtension
TypeApplications KnownExtension -> [KnownExtension] -> Bool
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 <- Lex a Char
forall r. Lex r Char
getLastChar
                                                if Char -> Bool
isIdent Char
lc
                                                  then Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
At
                                                  else Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
TApp

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


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

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

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

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

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

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

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

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

      where lexIdents :: Lex a [String]
            lexIdents :: Lex a [String]
lexIdents = do
                String
ident <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
                String
s <- Lex a String
forall r. Lex r String
getInput
                [KnownExtension]
exts <- Lex a [KnownExtension]
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.
                 '-':c :: Char
c:_ | KnownExtension
XmlSyntax KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts Bool -> Bool -> Bool
&& Char -> Bool
isAlpha Char
c -> do
                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1
                        [String]
idents <- Lex a [String]
forall a. Lex a [String]
lexIdents
                        [String] -> Lex a [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> Lex a [String]) -> [String] -> Lex a [String]
forall a b. (a -> b) -> a -> b
$ String
ident String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
idents
                 '#':_ | KnownExtension
MagicHash KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
                        String
hashes <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '#')
                        [String] -> Lex a [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
ident String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
hashes]
                 _ -> [String] -> Lex a [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
ident]

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

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

unboxed :: [KnownExtension] -> Bool
unboxed :: [KnownExtension] -> Bool
unboxed exts :: [KnownExtension]
exts = KnownExtension
UnboxedSums KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts Bool -> Bool -> Bool
|| KnownExtension
UnboxedTuples KnownExtension -> [KnownExtension] -> Bool
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 s :: String
s =
    case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s of
      x :: String
x | "options_" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x -> Token -> Maybe Token
forall a. a -> Maybe a
Just (Token -> Maybe Token) -> Token -> Maybe Token
forall a b. (a -> b) -> a -> b
$ (Maybe String, String) -> Token
OPTIONS (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
drop 8 String
s, String
forall a. HasCallStack => a
undefined)
        | "options" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
x            -> Token -> Maybe Token
forall a. a -> Maybe a
Just (Token -> Maybe Token) -> Token -> Maybe Token
forall a b. (a -> b) -> a -> b
$ (Maybe String, String) -> Token
OPTIONS (Maybe String
forall a. Maybe a
Nothing, String
forall a. HasCallStack => a
undefined)
        | Bool
otherwise                 -> String -> [(String, Token)] -> Maybe Token
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
x [(String, Token)]
pragmas

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

     Just (OPTIONS opt :: (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 (' ':xs :: String
xs) = String
xs
                dropIfSpace xs :: String
xs       = String
xs
             in
              case (Maybe String, String) -> Maybe String
forall a b. (a, b) -> a
fst (Maybe String, String)
opt of
                Just opt' :: String
opt' -> do
                  String
rest <- Lex a String
forall r. Lex r String
lexRawPragma
                  Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ (Maybe String, String) -> Token
OPTIONS (String -> Maybe String
forall a. a -> Maybe a
Just String
opt', ShowS
dropIfSpace String
rest)
                Nothing -> do
                  String
s <- Lex a String
forall r. Lex r String
getInput
                  case String
s of
                    x :: Char
x:_ | Char -> Bool
isSpace Char
x -> do
                      String
rest <- Lex a String
forall r. Lex r String
lexRawPragma
                      Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ (Maybe String, String) -> Token
OPTIONS (Maybe String
forall a. Maybe a
Nothing, ShowS
dropIfSpace String
rest)
                    _  -> String -> Lex a Token
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Malformed Options pragma"
     Just RULES -> do -- Rules enable ScopedTypeVariables locally.
            KnownExtension -> Lex a ()
forall a. KnownExtension -> Lex a ()
addExtensionL KnownExtension
ScopedTypeVariables
            Token -> Lex a Token
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 p :: Token
p ->  Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
p

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

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

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

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

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

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

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

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

lexCharacter :: Lex a Token
lexCharacter :: 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 <- Lex a String
forall r. Lex r String
getInput
        [KnownExtension]
exts <- Lex a [KnownExtension]
forall a. Lex a [KnownExtension]
getExtensionsL
        case String
s of
         '\'':_ | KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard 1 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THTyQuote
         '\\':_ -> do
                    (c :: Char
c,raw :: String
raw) <- Lex a (Char, String)
forall a. Lex a (Char, String)
lexEscape
                    Lex a ()
forall a. Lex a ()
matchQuote
                    (Char, String) -> Token
con <- ((Char, String) -> Token)
-> ((Char, String) -> Token)
-> Either String ((Char, String) -> Token)
-> Lex a ((Char, String) -> Token)
forall b a.
(b -> Token)
-> (b -> Token) -> Either String (b -> Token) -> Lex a (b -> Token)
lexHash (Char, String) -> Token
Character (Char, String) -> Token
CharacterHash
                            (String -> Either String ((Char, String) -> Token)
forall a b. a -> Either a b
Left "Double hash not available for character literals")
                    Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return ((Char, String) -> Token
con (Char
c, '\\'Char -> ShowS
forall a. a -> [a] -> [a]
:String
raw))
         c :: Char
c:'\'':_ -> do
                    Int -> Lex a ()
forall r. Int -> Lex r ()
discard 2
                    (Char, String) -> Token
con <- ((Char, String) -> Token)
-> ((Char, String) -> Token)
-> Either String ((Char, String) -> Token)
-> Lex a ((Char, String) -> Token)
forall b a.
(b -> Token)
-> (b -> Token) -> Either String (b -> Token) -> Lex a (b -> Token)
lexHash (Char, String) -> Token
Character (Char, String) -> Token
CharacterHash
                            (String -> Either String ((Char, String) -> Token)
forall a b. a -> Either a b
Left "Double hash not available for character literals")
                    Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return ((Char, String) -> Token
con (Char
c, [Char
c]))
         _ | (KnownExtension -> Bool) -> [KnownExtension] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts) [KnownExtension
TemplateHaskell, KnownExtension
DataKinds] -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THVarQuote
         _ -> String -> Lex a Token
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Improper character constant or misplaced \'"

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


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

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

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

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

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

-- Production ascii from section B.2

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

-- Escaped numbers

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

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

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

-- Production cntrl from section B.2

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

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

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

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

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

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

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

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

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

  EOF           -> "EOF"