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

reserved_ops :: [(String,(Token, Maybe ExtScheme))]
reserved_ops :: [([Char], (Token, Maybe ExtScheme))]
reserved_ops = [
 ( [Char]
"..", (Token
DotDot,       Maybe ExtScheme
forall a. Maybe a
Nothing) ),
 ( [Char]
":",  (Token
Colon,        Maybe ExtScheme
forall a. Maybe a
Nothing) ),
 ( [Char]
"::", (Token
DoubleColon,  Maybe ExtScheme
forall a. Maybe a
Nothing) ),
 ( [Char]
"=",  (Token
Equals,       Maybe ExtScheme
forall a. Maybe a
Nothing) ),
 ( [Char]
"\\", (Token
Backslash,    Maybe ExtScheme
forall a. Maybe a
Nothing) ),
 ( [Char]
"|",  (Token
Bar,          Maybe ExtScheme
forall a. Maybe a
Nothing) ),
 ( [Char]
"<-", (Token
LeftArrow,    Maybe ExtScheme
forall a. Maybe a
Nothing) ),
 ( [Char]
"->", (Token
RightArrow,   Maybe ExtScheme
forall a. Maybe a
Nothing) ),
 ( [Char]
"@",  (Token
At,           Maybe ExtScheme
forall a. Maybe a
Nothing) ),
 ( [Char]
"@:", (Token
RPCAt,        ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
RegularPatterns])) ),
 ( [Char]
"~",  (Token
Tilde,        Maybe ExtScheme
forall a. Maybe a
Nothing) ),
 ( [Char]
"=>", (Token
DoubleArrow,  Maybe ExtScheme
forall a. Maybe a
Nothing) ),
 ( [Char]
"*",  (Token
Star,         ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
KindSignatures])) ),
 -- Parallel arrays
 ( [Char]
"[:", (Token
ParArrayLeftSquare,   ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ParallelArrays])) ),
 ( [Char]
":]", (Token
ParArrayRightSquare,  ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ParallelArrays])) ),
 -- Arrows notation
 ( [Char]
"-<",  (Token
LeftArrowTail,       ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
Arrows])) ),
 ( [Char]
">-",  (Token
RightArrowTail,      ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
Arrows])) ),
 ( [Char]
"-<<", (Token
LeftDblArrowTail,    ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
Arrows])) ),
 ( [Char]
">>-", (Token
RightDblArrowTail,   ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
Arrows])) ),
 -- Unicode notation
 ( [Char]
"\x2190",    (Token
LeftArrow,     ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any  [KnownExtension
UnicodeSyntax])) ),
 ( [Char]
"\x2192",    (Token
RightArrow,    ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any  [KnownExtension
UnicodeSyntax])) ),
 ( [Char]
"\x21d2",    (Token
DoubleArrow,   ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any  [KnownExtension
UnicodeSyntax])) ),
 ( [Char]
"\x2237",    (Token
DoubleColon,   ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any  [KnownExtension
UnicodeSyntax])) ),
 ( [Char]
"\x2919",    (Token
LeftArrowTail,     ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
All [KnownExtension
UnicodeSyntax, KnownExtension
Arrows])) ),
 ( [Char]
"\x291a",    (Token
RightArrowTail,    ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
All [KnownExtension
UnicodeSyntax, KnownExtension
Arrows])) ),
 ( [Char]
"\x291b",    (Token
LeftDblArrowTail,  ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
All [KnownExtension
UnicodeSyntax, KnownExtension
Arrows])) ),
 ( [Char]
"\x291c",    (Token
RightDblArrowTail, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
All [KnownExtension
UnicodeSyntax, KnownExtension
Arrows])) ),
 ( [Char]
"\x2605",    (Token
Star,              ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
All [KnownExtension
UnicodeSyntax, KnownExtension
KindSignatures])) ),
 ( [Char]
"\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 :: [([Char], (Token, Maybe ExtScheme))]
special_varops = [
 -- the dot is only a special symbol together with forall, but can still be used as function composition
 ( [Char]
".",  (Token
Dot,          ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ExplicitForAll, KnownExtension
ExistentialQuantification])) ),
 ( [Char]
"-",  (Token
Minus,        Maybe ExtScheme
forall a. Maybe a
Nothing) ),
 ( [Char]
"!",  (Token
Exclamation,  Maybe ExtScheme
forall a. Maybe a
Nothing) )
 ]

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

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

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

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

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

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

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

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


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

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

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

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

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

isRecognisedPragma, isLinePragma :: String -> Bool
isRecognisedPragma :: [Char] -> Bool
isRecognisedPragma [Char]
str = let pragma :: [Char]
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
$ [Char]
str
                          in case [Char] -> Maybe Token
lookupKnownPragma [Char]
pragma of
                              Maybe Token
Nothing -> Bool
False
                              Maybe Token
_       -> Bool
True

isLinePragma :: [Char] -> Bool
isLinePragma [Char]
str = let pragma :: [Char]
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
$ [Char]
str
                    in case [Char]
pragma of
                        [Char]
"line"  -> Bool
True
                        [Char]
_       -> Bool
False

lexLinePragma :: Lex a (Int, String)
lexLinePragma :: forall a. Lex a (Int, [Char])
lexLinePragma = do
    Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3   -- {-#
    (Char -> Bool) -> Lex a ()
forall a. (Char -> Bool) -> Lex a ()
lexWhile_ Char -> Bool
isSpace
    Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
4   -- LINE
    (Char -> Bool) -> Lex a ()
forall a. (Char -> Bool) -> Lex a ()
lexWhile_ Char -> Bool
isSpace
    i <- (Char -> Bool) -> Lex a [Char]
forall a. (Char -> Bool) -> Lex a [Char]
lexWhile Char -> Bool
isDigit
    when (null i) $ fail "Improperly formatted LINE pragma"
    lexWhile_ isSpace
    matchChar '"' "Improperly formatted LINE pragma"
    fn <- lexWhile (/= '"')
    matchChar '"' "Impossible - lexLinePragma"
    lexWhile_ isSpace
    mapM_ (flip matchChar "Improperly formatted LINE pragma") "#-}"
    lexNewline
    return (read i, fn)

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

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

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

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


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


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


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

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

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

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

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

        Char
'0':Char
c:Char
d:[Char]
_ | Char -> Char
toLower Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'o' Bool -> Bool -> Bool
&& Char -> Bool
isOctDigit Char
d -> do
                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
                        (n, str) <- Lex a (Integer, [Char])
forall a. Lex a (Integer, [Char])
lexOctal
                        con <- intHash
                        return (con (n, '0':c:str))
                  | Char -> Char
toLower Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'b' Bool -> Bool -> Bool
&& Char -> Bool
isBinDigit Char
d Bool -> Bool -> Bool
&& KnownExtension
BinaryLiterals KnownExtension -> [KnownExtension] -> Bool
forall a. Eq a => a -> [a] -> 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 Int
2
                        (n, str) <- Lex a (Integer, [Char])
forall a. Lex a (Integer, [Char])
lexBinary
                        con <- intHash
                        return (con (n, '0':c:str))
                  | Char -> Char
toLower Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'x' Bool -> Bool -> Bool
&& Char -> Bool
isHexDigit Char
d -> do
                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
                        (n, str) <- Lex a (Integer, [Char])
forall a. Lex a (Integer, [Char])
lexHexadecimal
                        con <- intHash
                        return (con (n, '0':c:str))

        -- implicit parameters
        Char
'?':Char
c:[Char]
_ | Char -> Bool
isIdentStart Char
c Bool -> Bool -> Bool
&& KnownExtension
ImplicitParams KnownExtension -> [KnownExtension] -> Bool
forall a. Eq a => a -> [a] -> 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 Int
1
                        id <- (Char -> Bool) -> Lex a [Char]
forall a. (Char -> Bool) -> Lex a [Char]
lexWhile Char -> Bool
isIdent
                        return $ IDupVarId id

        Char
'%':Char
c:[Char]
_ | Char -> Bool
isIdentStart Char
c Bool -> Bool -> Bool
&& KnownExtension
ImplicitParams KnownExtension -> [KnownExtension] -> Bool
forall a. Eq a => a -> [a] -> 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 Int
1
                        id <- (Char -> Bool) -> Lex a [Char]
forall a. (Char -> Bool) -> Lex a [Char]
lexWhile Char -> Bool
isIdent
                        return $ ILinVarId id
        -- end implicit parameters

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


        -- template haskell
        Char
'[':Char
'|':Char
'|':[Char]
_ | KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall a. Eq a => a -> [a] -> 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 Int
3
                Token -> Lex a Token
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THTExpQuote

        Char
'[':Char
'e':Char
'|':Char
'|':[Char]
_ | KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall a. Eq a => a -> [a] -> 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 Int
4
                Token -> Lex a Token
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THTExpQuote

        Char
'[':Char
'|':[Char]
_ | KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall a. Eq a => a -> [a] -> 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 Int
2
                Token -> Lex a Token
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THExpQuote

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

        Char
'[':Char
c:[Char]
s' | Char -> Bool
isIdentStart Char
c Bool -> Bool -> Bool
&& KnownExtension
QuasiQuotes KnownExtension -> [KnownExtension] -> Bool
forall a. Eq a => a -> [a] -> 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 [Char]
s' of { Char
'|':[Char]
_ -> Bool
True;[Char]
_->Bool
False} ->
                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a Token -> Lex a Token
forall a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Token
forall a. Char -> Lex a Token
lexQuasiQuote Char
c
                 | Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
&& KnownExtension
QuasiQuotes KnownExtension -> [KnownExtension] -> Bool
forall a. Eq a => a -> [a] -> 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 [Char]
s' of { Char
'|':[Char]
_ -> Bool
True;[Char]
_->Bool
False} ->
                        Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a Token -> Lex a Token
forall a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Token
forall a. Char -> Lex a Token
lexQuasiQuote Char
c

        Char
'|':Char
'|':Char
']':[Char]
_ | KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall a. Eq a => a -> [a] -> 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 Int
3
                        Token -> Lex a Token
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THTCloseQuote
        Char
'|':Char
']':[Char]
_ | KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall a. Eq a => a -> [a] -> 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 Int
2
                        Token -> Lex a Token
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THCloseQuote

        Char
'$':Char
c1:Char
c2:[Char]
_ | Char -> Bool
isIdentStart Char
c1 Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall a. Eq a => a -> [a] -> 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 Int
1
                        id <- (Char -> Bool) -> Lex a [Char]
forall a. (Char -> Bool) -> Lex a [Char]
lexWhile Char -> Bool
isIdent
                        return $ THIdEscape id
                    | Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall a. Eq a => a -> [a] -> 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 Int
2
                        Token -> Lex a Token
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THParenEscape
                    | Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'$' Bool -> Bool -> Bool
&& Char -> Bool
isIdentStart Char
c2 Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall a. Eq a => a -> [a] -> 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 Int
2
                        id <- (Char -> Bool) -> Lex a [Char]
forall a. (Char -> Bool) -> Lex a [Char]
lexWhile Char -> Bool
isIdent
                        return $ THTIdEscape id
                    | Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'$' Bool -> Bool -> Bool
&& Char
c2 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall a. Eq a => a -> [a] -> 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 Int
3
                        Token -> Lex a Token
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THTParenEscape
        -- end template haskell

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

        Char
'(':Char
'#':Char
c:[Char]
_ | [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 Int
2 Lex a () -> Lex a Token -> Lex a Token
forall a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Token
LeftHashParen

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

        -- pragmas

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

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

        -- Parallel arrays

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

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

        -- Lexed seperately to deal with visible type applciation

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

        Char
'#':Char
c:[Char]
_ | KnownExtension
OverloadedLabels KnownExtension -> [KnownExtension] -> Bool
forall a. Eq a => a -> [a] -> 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 Int
1
                                                  [ident] <- Lex a [[Char]]
forall a. Lex a [[Char]]
lexIdents
                                                  return $ LabelVarId ident


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

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

            | Char -> Bool
isIdentStart Char
c -> do
                    idents <- Lex a [[Char]]
forall a. Lex a [[Char]]
lexIdents
                    case idents of
                     [[Char]
ident] -> case [Char]
-> [([Char], (Token, Maybe ExtScheme))]
-> Maybe (Token, Maybe ExtScheme)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
ident ([([Char], (Token, Maybe ExtScheme))]
reserved_ids [([Char], (Token, Maybe ExtScheme))]
-> [([Char], (Token, Maybe ExtScheme))]
-> [([Char], (Token, Maybe ExtScheme))]
forall a. [a] -> [a] -> [a]
++ [([Char], (Token, Maybe ExtScheme))]
special_varids) of
                                 Just (Token
keyword, 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 a b. Lex a a -> Lex a b -> Lex a b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return Token
keyword
                                     else Token -> Lex a Token
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ [Char] -> Token
VarId [Char]
ident
                                 Maybe (Token, Maybe ExtScheme)
Nothing -> Token -> Lex a Token
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ [Char] -> Token
VarId [Char]
ident
                     [[Char]]
_ -> Token -> Lex a Token
forall a. a -> Lex a a
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Token
DVarId [[Char]]
idents

            | Char -> Bool
isHSymbol Char
c -> do
                    sym <- (Char -> Bool) -> Lex a [Char]
forall a. (Char -> Bool) -> Lex a [Char]
lexWhile Char -> Bool
isHSymbol
                    return $ case lookup sym (reserved_ops ++ special_varops) of
                              Just (Token
t , 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
                                        Char
':' -> [Char] -> Token
ConSym [Char]
sym
                                        Char
_   -> [Char] -> Token
VarSym [Char]
sym
                              Maybe (Token, Maybe ExtScheme)
Nothing -> case Char
c of
                                          Char
':' -> [Char] -> Token
ConSym [Char]
sym
                                          Char
_   -> [Char] -> Token
VarSym [Char]
sym

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

-- Production ascii from section B.2

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

-- Escaped numbers

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

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

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

-- Production cntrl from section B.2

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

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

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

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

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

-- Stolen from Hugs's Prelude
parseInteger :: Integer -> String -> Integer
parseInteger :: Integer -> [Char] -> Integer
parseInteger Integer
radix [Char]
ds =
    (Integer -> Integer -> Integer) -> [Integer] -> Integer
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Integer
n Integer
d -> Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
radix Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
d) ((Char -> Integer) -> [Char] -> [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) [Char]
ds)

flagKW :: Token -> Lex a ()
flagKW :: forall a. Token -> Lex a ()
flagKW Token
t =
  Bool -> Lex a () -> Lex a ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Token
t Token -> [Token] -> Bool
forall a. Eq a => a -> [a] -> 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
       exts <- Lex a [KnownExtension]
forall a. Lex a [KnownExtension]
getExtensionsL
       when (NondecreasingIndentation `elem` exts) flagDo

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

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

  Token
EOF           -> [Char]
"EOF"