{-# OPTIONS_HADDOCK hide #-}
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)
data Token
= VarId String
| LabelVarId String
| QVarId (String,String)
| IDupVarId (String)
| ILinVarId (String)
| ConId String
| QConId (String,String)
| DVarId [String]
| 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)
| WordTokHash (Integer, String)
| FloatTokHash (Rational, String)
| DoubleTokHash (Rational, String)
| CharacterHash (Char, String)
| StringHash (String, String)
| LeftParen
| RightParen
| LeftHashParen
| RightHashParen
| SemiColon
| LeftCurly
| RightCurly
| VRightCurly
| LeftSquare
| RightSquare
| ParArrayLeftSquare
| ParArrayRightSquare
| Comma
| Underscore
| BackQuote
| Dot
| DotDot
| Colon
| QuoteColon
| DoubleColon
| Equals
| Backslash
| Bar
| LeftArrow
| RightArrow
| At
| TApp
| Tilde
| DoubleArrow
| Minus
| Exclamation
| Star
| LeftArrowTail
| RightArrowTail
| LeftDblArrowTail
| RightDblArrowTail
| OpenArrowBracket
| CloseArrowBracket
| THExpQuote
| THTExpQuote
| THPatQuote
| THDecQuote
| THTypQuote
| THCloseQuote
| THTCloseQuote
| THIdEscape (String)
| THParenEscape
| THTIdEscape String
| THTParenEscape
| THVarQuote
| THTyQuote
| THQuasiQuote (String,String)
| RPGuardOpen
| RPGuardClose
| RPCAt
| XCodeTagOpen
| XCodeTagClose
| XStdTagOpen
| XStdTagClose
| XCloseTagOpen
| XEmptyTagClose
| XChildTagOpen
| XPCDATA String
| XRPatOpen
| XRPatClose
| PragmaEnd
| RULES
| INLINE Bool
| INLINE_CONLIKE
| SPECIALISE
| SPECIALISE_INLINE Bool
| SOURCE
| DEPRECATED
| WARNING
| SCC
| GENERATED
| CORE
| UNPACK
| NOUNPACK
| OPTIONS (Maybe String,String)
| LANGUAGE
| ANN
| MINIMAL
| NO_OVERLAP
| OVERLAP
| OVERLAPPING
| OVERLAPPABLE
| OVERLAPS
| INCOHERENT
| COMPLETE
| KW_As
| KW_By
| KW_Case
| KW_Class
| KW_Data
| KW_Default
| KW_Deriving
| KW_Do
| KW_MDo
| KW_Else
| KW_Family
| KW_Forall
| KW_Group
| 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
| KW_Rec
| KW_Role
| KW_Then
| KW_Type
| KW_Using
| KW_Where
| KW_Qualified
| KW_Pattern
| KW_Stock
| KW_Anyclass
| KW_Via
| KW_Foreign
| KW_Export
| KW_Safe
| KW_Unsafe
| KW_Threadsafe
| KW_Interruptible
| KW_StdCall
| KW_CCall
| KW_CPlusPlus
| KW_DotNet
| KW_Jvm
| KW_Js
| KW_JavaScript
| KW_CApi
| EOF
deriving (Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq,Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
(Int -> Token -> ShowS)
-> (Token -> String) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show)
reserved_ops :: [(String,(Token, Maybe ExtScheme))]
reserved_ops :: [(String, (Token, Maybe ExtScheme))]
reserved_ops = [
( String
"..", (Token
DotDot, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
":", (Token
Colon, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"::", (Token
DoubleColon, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"=", (Token
Equals, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"\\", (Token
Backslash, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"|", (Token
Bar, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"<-", (Token
LeftArrow, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"->", (Token
RightArrow, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"@", (Token
At, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"@:", (Token
RPCAt, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
RegularPatterns])) ),
( String
"~", (Token
Tilde, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"=>", (Token
DoubleArrow, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"*", (Token
Star, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
KindSignatures])) ),
( String
"[:", (Token
ParArrayLeftSquare, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ParallelArrays])) ),
( String
":]", (Token
ParArrayRightSquare, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ParallelArrays])) ),
( String
"-<", (Token
LeftArrowTail, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
Arrows])) ),
( String
">-", (Token
RightArrowTail, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
Arrows])) ),
( String
"-<<", (Token
LeftDblArrowTail, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
Arrows])) ),
( String
">>-", (Token
RightDblArrowTail, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
Arrows])) ),
( String
"\x2190", (Token
LeftArrow, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
UnicodeSyntax])) ),
( String
"\x2192", (Token
RightArrow, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
UnicodeSyntax])) ),
( String
"\x21d2", (Token
DoubleArrow, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
UnicodeSyntax])) ),
( String
"\x2237", (Token
DoubleColon, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
UnicodeSyntax])) ),
( String
"\x2919", (Token
LeftArrowTail, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
All [KnownExtension
UnicodeSyntax, KnownExtension
Arrows])) ),
( String
"\x291a", (Token
RightArrowTail, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
All [KnownExtension
UnicodeSyntax, KnownExtension
Arrows])) ),
( String
"\x291b", (Token
LeftDblArrowTail, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
All [KnownExtension
UnicodeSyntax, KnownExtension
Arrows])) ),
( String
"\x291c", (Token
RightDblArrowTail, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
All [KnownExtension
UnicodeSyntax, KnownExtension
Arrows])) ),
( String
"\x2605", (Token
Star, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
All [KnownExtension
UnicodeSyntax, KnownExtension
KindSignatures])) ),
( String
"\x2200", (Token
KW_Forall, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
All [KnownExtension
UnicodeSyntax, KnownExtension
ExplicitForAll])) )
]
special_varops :: [(String,(Token, Maybe ExtScheme))]
special_varops :: [(String, (Token, Maybe ExtScheme))]
special_varops = [
( String
".", (Token
Dot, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ExplicitForAll, KnownExtension
ExistentialQuantification])) ),
( String
"-", (Token
Minus, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"!", (Token
Exclamation, Maybe ExtScheme
forall a. Maybe a
Nothing) )
]
reserved_ids :: [(String,(Token, Maybe ExtScheme))]
reserved_ids :: [(String, (Token, Maybe ExtScheme))]
reserved_ids = [
( String
"_", (Token
Underscore, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"by", (Token
KW_By, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
TransformListComp])) ),
( String
"case", (Token
KW_Case, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"class", (Token
KW_Class, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"data", (Token
KW_Data, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"default", (Token
KW_Default, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"deriving", (Token
KW_Deriving, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"do", (Token
KW_Do, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"else", (Token
KW_Else, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"family", (Token
KW_Family, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
TypeFamilies])) ),
( String
"forall", (Token
KW_Forall, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ExplicitForAll, KnownExtension
ExistentialQuantification])) ),
( String
"group", (Token
KW_Group, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
TransformListComp])) ),
( String
"if", (Token
KW_If, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"import", (Token
KW_Import, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"in", (Token
KW_In, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"infix", (Token
KW_Infix, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"infixl", (Token
KW_InfixL, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"infixr", (Token
KW_InfixR, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"instance", (Token
KW_Instance, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"let", (Token
KW_Let, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"mdo", (Token
KW_MDo, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
RecursiveDo])) ),
( String
"module", (Token
KW_Module, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"newtype", (Token
KW_NewType, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"of", (Token
KW_Of, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"proc", (Token
KW_Proc, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
Arrows])) ),
( String
"rec", (Token
KW_Rec, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
Arrows, KnownExtension
RecursiveDo, KnownExtension
DoRec])) ),
( String
"then", (Token
KW_Then, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"type", (Token
KW_Type, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"using", (Token
KW_Using, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
TransformListComp])) ),
( String
"where", (Token
KW_Where, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"role", (Token
KW_Role, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
RoleAnnotations]))),
( String
"pattern", (Token
KW_Pattern, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
PatternSynonyms]))),
( String
"stock", (Token
KW_Stock, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
DerivingStrategies]))),
( String
"anyclass", (Token
KW_Anyclass, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
DerivingStrategies]))),
( String
"via", (Token
KW_Via, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
DerivingVia]))),
( String
"foreign", (Token
KW_Foreign, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) )
]
special_varids :: [(String,(Token, Maybe ExtScheme))]
special_varids :: [(String, (Token, Maybe ExtScheme))]
special_varids = [
( String
"as", (Token
KW_As, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"qualified", (Token
KW_Qualified, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"hiding", (Token
KW_Hiding, Maybe ExtScheme
forall a. Maybe a
Nothing) ),
( String
"export", (Token
KW_Export, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
( String
"safe", (Token
KW_Safe, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface, KnownExtension
SafeImports, KnownExtension
Safe, KnownExtension
Trustworthy])) ),
( String
"unsafe", (Token
KW_Unsafe, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
( String
"threadsafe", (Token
KW_Threadsafe, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
( String
"interruptible", (Token
KW_Interruptible, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
InterruptibleFFI])) ),
( String
"stdcall", (Token
KW_StdCall, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
( String
"ccall", (Token
KW_CCall, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
( String
"cplusplus", (Token
KW_CPlusPlus, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
( String
"dotnet", (Token
KW_DotNet, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
( String
"jvm", (Token
KW_Jvm, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
( String
"js", (Token
KW_Js, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
( String
"javascript", (Token
KW_JavaScript, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
ForeignFunctionInterface])) ),
( String
"capi", (Token
KW_CApi, ExtScheme -> Maybe ExtScheme
forall a. a -> Maybe a
Just ([KnownExtension] -> ExtScheme
Any [KnownExtension
CApiFFI])) )
]
pragmas :: [(String,Token)]
pragmas :: [(String, Token)]
pragmas = [
( String
"rules", Token
RULES ),
( String
"inline", Bool -> Token
INLINE Bool
True ),
( String
"noinline", Bool -> Token
INLINE Bool
False ),
( String
"notinline", Bool -> Token
INLINE Bool
False ),
( String
"specialise", Token
SPECIALISE ),
( String
"specialize", Token
SPECIALISE ),
( String
"source", Token
SOURCE ),
( String
"deprecated", Token
DEPRECATED ),
( String
"warning", Token
WARNING ),
( String
"ann", Token
ANN ),
( String
"scc", Token
SCC ),
( String
"generated", Token
GENERATED ),
( String
"core", Token
CORE ),
( String
"unpack", Token
UNPACK ),
( String
"nounpack", Token
NOUNPACK ),
( String
"language", Token
LANGUAGE ),
( String
"minimal", Token
MINIMAL ),
( String
"no_overlap", Token
NO_OVERLAP ),
( String
"overlap", Token
OVERLAP ),
( String
"overlaps", Token
OVERLAPS ),
( String
"overlapping", Token
OVERLAPPING ),
( String
"overlappable", Token
OVERLAPPABLE ),
( String
"incoherent", Token
INCOHERENT ),
( String
"complete", Token
COMPLETE ),
( String
"options", (Maybe String, String) -> Token
OPTIONS (Maybe String, String)
forall a. HasCallStack => a
undefined )
]
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 -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
":!#%&*./?@\\-" Bool -> Bool -> Bool
|| ((Char -> Bool
isSymbol Char
c Bool -> Bool -> Bool
|| Char -> Bool
isPunctuation Char
c) Bool -> Bool -> Bool
&& Bool -> Bool
not (Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"(),;[]`{}_\"'"))
isPragmaChar :: Char -> Bool
isPragmaChar Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c 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
'_'
isOpSymbol :: Char -> Bool
isOpSymbol :: Char -> Bool
isOpSymbol Char
c = Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"!#$%&*+./<=>?@\\^|-~"
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 :: Char -> String -> Lex a ()
matchChar Char
c String
msg = do
String
s <- Lex a String
forall r. Lex r String
getInput
if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s Bool -> Bool -> Bool
|| String -> Char
forall a. [a] -> a
head String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
c then String -> Lex a ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg else Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
lexer :: (Loc Token -> P a) -> P a
lexer :: (Loc Token -> P a) -> P a
lexer = Lex a (Loc Token) -> (Loc Token -> P a) -> P a
forall r a. Lex r a -> (a -> P r) -> P r
runL Lex a (Loc Token)
forall a. Lex a (Loc Token)
topLexer
topLexer :: Lex a (Loc Token)
topLexer :: Lex a (Loc Token)
topLexer = do
Bool
b <- Lex a Bool
forall a. Lex a Bool
pullCtxtFlag
if Bool
b then
Lex a ()
forall a. Lex a ()
setBOL Lex a () -> Lex a SrcLoc -> Lex a SrcLoc
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Lex a SrcLoc
forall a. Lex a SrcLoc
getSrcLocL Lex a SrcLoc -> (SrcLoc -> Lex a (Loc Token)) -> Lex a (Loc Token)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \SrcLoc
l -> Loc Token -> Lex a (Loc Token)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> Token -> Loc Token
forall a. SrcSpan -> a -> Loc a
Loc (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
l SrcLoc
l) Token
VRightCurly)
else do
Bool
bol <- Lex a Bool
forall a. Lex a Bool
checkBOL
(Bool
bol', Bool
ws) <- Bool -> Lex a (Bool, Bool)
forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
bol
Maybe ExtContext
ec <- Lex a (Maybe ExtContext)
forall a. Lex a (Maybe ExtContext)
getExtContext
case Maybe ExtContext
ec of
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \SrcLoc
l -> Loc Token -> Lex a (Loc Token)
forall (m :: * -> *) a. Monad m => a -> m a
return (Loc Token -> Lex a (Loc Token)) -> Loc Token -> Lex a (Loc Token)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Token -> Loc Token
forall a. SrcSpan -> a -> Loc a
Loc (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
l SrcLoc
l) (Token -> Loc Token) -> Token -> Loc Token
forall a b. (a -> b) -> a -> b
$ String -> Token
XPCDATA String
" "
Maybe ExtContext
_ -> do Lex a ()
forall a. Lex a ()
startToken
SrcLoc
sl <- Lex a SrcLoc
forall a. Lex a SrcLoc
getSrcLocL
Token
t <- if Bool
bol' then Lex a Token
forall a. Lex a Token
lexBOL
else Lex a Token
forall a. Lex a Token
lexToken
SrcLoc
el <- Lex a SrcLoc
forall a. Lex a SrcLoc
getSrcLocL
Loc Token -> Lex a (Loc Token)
forall (m :: * -> *) a. Monad m => a -> m a
return (Loc Token -> Lex a (Loc Token)) -> Loc Token -> Lex a (Loc Token)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Token -> Loc Token
forall a. SrcSpan -> a -> Loc a
Loc (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
sl SrcLoc
el) Token
t
lexWhiteSpace :: Bool -> Lex a (Bool, Bool)
lexWhiteSpace :: Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
bol = do
String
s <- Lex a String
forall r. Lex r String
getInput
Bool
ignL <- Lex a Bool
forall a. Lex a Bool
ignoreLinePragmasL
case String
s of
Char
'{':Char
'-':Char
'#':String
rest | String -> Bool
isRecognisedPragma String
rest -> (Bool, Bool) -> Lex a (Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
bol, Bool
False)
| String -> Bool
isLinePragma String
rest Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
ignL -> do
(Int
l, String
fn) <- Lex a (Int, String)
forall a. Lex a (Int, String)
lexLinePragma
Int -> Lex a ()
forall r. Int -> Lex r ()
setSrcLineL Int
l
String -> Lex a ()
forall a. String -> Lex a ()
setLineFilenameL String
fn
Bool -> Lex a (Bool, Bool)
forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
True
Char
'{':Char
'-':String
_ -> do
SrcLoc
loc <- Lex a SrcLoc
forall a. Lex a SrcLoc
getSrcLocL
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
(Bool
bol1, String
c) <- Bool -> String -> Lex a (Bool, String)
forall a. Bool -> String -> Lex a (Bool, String)
lexNestedComment Bool
bol String
""
SrcLoc
loc2 <- Lex a SrcLoc
forall a. Lex a SrcLoc
getSrcLocL
Comment -> Lex a ()
forall a. Comment -> Lex a ()
pushComment (Comment -> Lex a ()) -> Comment -> Lex a ()
forall a b. (a -> b) -> a -> b
$ Bool -> SrcSpan -> String -> Comment
Comment Bool
True (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
loc SrcLoc
loc2) (ShowS
forall a. [a] -> [a]
reverse String
c)
(Bool
bol2, Bool
_) <- Bool -> Lex a (Bool, Bool)
forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
bol1
(Bool, Bool) -> Lex a (Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
bol2, Bool
True)
Char
'-':Char
'-':String
s1 | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-') ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isHSymbol String
s1) -> do
SrcLoc
loc <- Lex a SrcLoc
forall a. Lex a SrcLoc
getSrcLocL
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
String
dashes <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-')
String
rest <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')
String
s' <- Lex a String
forall r. Lex r String
getInput
SrcLoc
loc2 <- Lex a SrcLoc
forall a. Lex a SrcLoc
getSrcLocL
let com :: Comment
com = Bool -> SrcSpan -> String -> Comment
Comment Bool
False (SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan SrcLoc
loc SrcLoc
loc2) (String -> Comment) -> String -> Comment
forall a b. (a -> b) -> a -> b
$ String
dashes String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
rest
case String
s' of
[] -> Comment -> Lex a ()
forall a. Comment -> Lex a ()
pushComment Comment
com Lex a () -> Lex a (Bool, Bool) -> Lex a (Bool, Bool)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Bool, Bool) -> Lex a (Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Bool
True)
String
_ -> do
Comment -> Lex a ()
forall a. Comment -> Lex a ()
pushComment Comment
com
Lex a ()
forall a. Lex a ()
lexNewline
Bool -> Lex a ()
forall a. Bool -> Lex a ()
lexWhiteSpace_ Bool
True
(Bool, Bool) -> Lex a (Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Bool
True)
Char
'\n':String
_ -> do
Lex a ()
forall a. Lex a ()
lexNewline
Bool -> Lex a ()
forall a. Bool -> Lex a ()
lexWhiteSpace_ Bool
True
(Bool, Bool) -> Lex a (Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Bool
True)
Char
'\t':String
_ -> do
Lex a ()
forall a. Lex a ()
lexTab
(Bool
bol', Bool
_) <- Bool -> Lex a (Bool, Bool)
forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
bol
(Bool, Bool) -> Lex a (Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
bol', Bool
True)
Char
c:String
_ | Char -> Bool
isSpace Char
c -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
(Bool
bol', Bool
_) <- Bool -> Lex a (Bool, Bool)
forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
bol
(Bool, Bool) -> Lex a (Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
bol', Bool
True)
String
_ -> (Bool, Bool) -> Lex a (Bool, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
bol, Bool
False)
lexWhiteSpace_ :: Bool -> Lex a ()
lexWhiteSpace_ :: Bool -> Lex a ()
lexWhiteSpace_ Bool
bol = do (Bool, Bool)
_ <- Bool -> Lex a (Bool, Bool)
forall a. Bool -> Lex a (Bool, Bool)
lexWhiteSpace Bool
bol
() -> Lex a ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
isRecognisedPragma, isLinePragma :: String -> Bool
isRecognisedPragma :: String -> Bool
isRecognisedPragma String
str = let pragma :: String
pragma = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isPragmaChar ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
str
in case String -> Maybe Token
lookupKnownPragma String
pragma of
Maybe Token
Nothing -> Bool
False
Maybe Token
_ -> Bool
True
isLinePragma :: String -> Bool
isLinePragma String
str = let pragma :: String
pragma = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isAlphaNum ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
str
in case String
pragma of
String
"line" -> Bool
True
String
_ -> Bool
False
lexLinePragma :: Lex a (Int, String)
lexLinePragma :: Lex a (Int, String)
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
(Char -> Bool) -> Lex a ()
forall a. (Char -> Bool) -> Lex a ()
lexWhile_ Char -> Bool
isSpace
String
i <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isDigit
Bool -> Lex a () -> Lex a ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
i) (Lex a () -> Lex a ()) -> Lex a () -> Lex a ()
forall a b. (a -> b) -> a -> b
$ String -> Lex a ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Improperly formatted LINE pragma"
(Char -> Bool) -> Lex a ()
forall a. (Char -> Bool) -> Lex a ()
lexWhile_ Char -> Bool
isSpace
Char -> String -> Lex a ()
forall a. Char -> String -> Lex a ()
matchChar Char
'"' String
"Improperly formatted LINE pragma"
String
fn <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"')
Char -> String -> Lex a ()
forall a. Char -> String -> Lex a ()
matchChar Char
'"' String
"Impossible - lexLinePragma"
(Char -> Bool) -> Lex a ()
forall a. (Char -> Bool) -> Lex a ()
lexWhile_ Char -> Bool
isSpace
(Char -> Lex a ()) -> String -> Lex a ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Char -> String -> Lex a ()) -> String -> Char -> Lex a ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> String -> Lex a ()
forall a. Char -> String -> Lex a ()
matchChar String
"Improperly formatted LINE pragma") String
"#-}"
Lex a ()
forall a. Lex a ()
lexNewline
(Int, String) -> Lex a (Int, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Int
forall a. Read a => String -> a
read String
i, String
fn)
lexNestedComment :: Bool -> String -> Lex a (Bool, String)
Bool
bol String
str = do
String
s <- Lex a String
forall r. Lex r String
getInput
case String
s of
Char
'-':Char
'}':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a (Bool, String) -> Lex a (Bool, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Bool, String) -> Lex a (Bool, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
bol, String
str)
Char
'{':Char
'-':String
_ -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
(Bool
bol', String
c) <- Bool -> String -> Lex a (Bool, String)
forall a. Bool -> String -> Lex a (Bool, String)
lexNestedComment Bool
bol (String
"-{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str)
Bool -> String -> Lex a (Bool, String)
forall a. Bool -> String -> Lex a (Bool, String)
lexNestedComment Bool
bol' (String
"}-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
c )
Char
'\t':String
_ -> Lex a ()
forall a. Lex a ()
lexTab Lex a () -> Lex a (Bool, String) -> Lex a (Bool, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> String -> Lex a (Bool, String)
forall a. Bool -> String -> Lex a (Bool, String)
lexNestedComment Bool
bol (Char
'\t'Char -> ShowS
forall a. a -> [a] -> [a]
:String
str)
Char
'\n':String
_ -> Lex a ()
forall a. Lex a ()
lexNewline Lex a () -> Lex a (Bool, String) -> Lex a (Bool, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> String -> Lex a (Bool, String)
forall a. Bool -> String -> Lex a (Bool, String)
lexNestedComment Bool
True (Char
'\n'Char -> ShowS
forall a. a -> [a] -> [a]
:String
str)
Char
c:String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a (Bool, String) -> Lex a (Bool, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> String -> Lex a (Bool, String)
forall a. Bool -> String -> Lex a (Bool, String)
lexNestedComment Bool
bol (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
str)
[] -> String -> Lex a (Bool, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unterminated nested comment"
lexBOL :: Lex a Token
lexBOL :: Lex a Token
lexBOL = do
Ordering
pos <- Lex a Ordering
forall a. Lex a Ordering
getOffside
case Ordering
pos of
Ordering
LT -> do
Lex a ()
forall a. Lex a ()
setBOL
String -> Lex a ()
forall a. String -> Lex a ()
popContextL String
"lexBOL"
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
VRightCurly
Ordering
EQ ->
Token -> Lex a Token
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 :: Lex a Token
lexToken = do
Maybe ExtContext
ec <- Lex a (Maybe ExtContext)
forall a. Lex a (Maybe ExtContext)
getExtContext
case Maybe ExtContext
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 :: Lex a Token
lexChildCtxt = do
String
s <- Lex a String
forall r. Lex r String
getInput
case String
s of
Char
'<':Char
'%':Char
'>':String
_ -> 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 (m :: * -> *) a. Monad m => a -> m a
return Token
XChildTagOpen
Char
'<':Char
'%':String
_ -> 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 (m :: * -> *) a. Monad m => a -> m a
return Token
XCodeTagOpen
Char
'<':Char
'/':String
_ -> do Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
String -> Lex a ()
forall a. String -> Lex a ()
popExtContextL String
"lexChildCtxt"
ExtContext -> Lex a ()
forall a. ExtContext -> Lex a ()
pushExtContextL ExtContext
CloseTagCtxt
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
XCloseTagOpen
Char
'<':Char
'[':String
_ -> 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 (m :: * -> *) a. Monad m => a -> m a
return Token
XRPatOpen
Char
'<':String
_ -> 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 (m :: * -> *) a. Monad m => a -> m a
return Token
XStdTagOpen
String
_ -> Lex a Token
forall a. Lex a Token
lexPCDATA
lexPCDATA :: Lex a Token
lexPCDATA :: Lex a Token
lexPCDATA = do
String
s <- Lex a String
forall r. Lex r String
getInput
case String
s of
[] -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
EOF
String
_ -> case String
s of
Char
'\n':String
_ -> do
Token
x <- Lex a ()
forall a. Lex a ()
lexNewline Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Lex a Token
forall a. Lex a Token
lexPCDATA
case Token
x of
XPCDATA String
p -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ String -> Token
XPCDATA (String -> Token) -> String -> Token
forall a b. (a -> b) -> a -> b
$ Char
'\n'Char -> ShowS
forall a. a -> [a] -> [a]
:String
p
Token
EOF -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
EOF
Token
_ -> String -> Lex a Token
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Lex a Token) -> String -> Lex a Token
forall a b. (a -> b) -> a -> b
$ String
"lexPCDATA: unexpected token: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Token -> String
forall a. Show a => a -> String
show Token
x
Char
'<':String
_ -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ String -> Token
XPCDATA String
""
String
_ -> do let pcd :: String
pcd = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Char
c -> Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"<\n") String
s
l :: Int
l = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pcd
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
l
Token
x <- Lex a Token
forall a. Lex a Token
lexPCDATA
case Token
x of
XPCDATA String
pcd' -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ String -> Token
XPCDATA (String -> Token) -> String -> Token
forall a b. (a -> b) -> a -> b
$ String
pcd String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pcd'
Token
EOF -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
EOF
Token
_ -> String -> Lex a Token
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Lex a Token) -> String -> Lex a Token
forall a b. (a -> b) -> a -> b
$ String
"lexPCDATA: unexpected token: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Token -> String
forall a. Show a => a -> String
show Token
x
lexCodeTagCtxt :: Lex a Token
lexCodeTagCtxt :: Lex a Token
lexCodeTagCtxt = do
String
s <- Lex a String
forall r. Lex r String
getInput
case String
s of
Char
'%':Char
'>':String
_ -> do Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
String -> Lex a ()
forall a. String -> Lex a ()
popExtContextL String
"lexCodeTagContext"
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
XCodeTagClose
String
_ -> Lex a Token
forall a. Lex a Token
lexStdToken
lexCloseTagCtxt :: Lex a Token
lexCloseTagCtxt :: Lex a Token
lexCloseTagCtxt = do
String
s <- Lex a String
forall r. Lex r String
getInput
case String
s of
Char
'%':Char
'>':String
_ -> do Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
String -> Lex a ()
forall a. String -> Lex a ()
popExtContextL String
"lexCloseTagCtxt"
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
XCodeTagClose
Char
'>':String
_ -> do Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
String -> Lex a ()
forall a. String -> Lex a ()
popExtContextL String
"lexCloseTagCtxt"
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
XStdTagClose
String
_ -> Lex a Token
forall a. Lex a Token
lexStdToken
lexTagCtxt :: Lex a Token
lexTagCtxt :: Lex a Token
lexTagCtxt = do
String
s <- Lex a String
forall r. Lex r String
getInput
case String
s of
Char
'/':Char
'>':String
_ -> do Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
String -> Lex a ()
forall a. String -> Lex a ()
popExtContextL String
"lexTagCtxt: Empty tag"
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
XEmptyTagClose
Char
'>':String
_ -> do Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
String -> Lex a ()
forall a. String -> Lex a ()
popExtContextL String
"lexTagCtxt: Standard tag"
ExtContext -> Lex a ()
forall a. ExtContext -> Lex a ()
pushExtContextL ExtContext
ChildCtxt
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
XStdTagClose
String
_ -> Lex a Token
forall a. Lex a Token
lexStdToken
lexHarpToken :: Lex a Token
lexHarpToken :: Lex a Token
lexHarpToken = do
String
s <- Lex a String
forall r. Lex r String
getInput
case String
s of
Char
']':Char
'>':String
_ -> do Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
String -> Lex a ()
forall a. String -> Lex a ()
popExtContextL String
"lexHarpToken"
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
XRPatClose
String
_ -> Lex a Token
forall a. Lex a Token
lexStdToken
lexStdToken :: Lex a Token
lexStdToken :: Lex a Token
lexStdToken = do
String
s <- Lex a String
forall r. Lex r String
getInput
[KnownExtension]
exts <- Lex a [KnownExtension]
forall a. Lex a [KnownExtension]
getExtensionsL
let intHash :: Lex a ((Integer, String) -> Token)
intHash = ((Integer, String) -> Token)
-> ((Integer, String) -> Token)
-> Either String ((Integer, String) -> Token)
-> Lex a ((Integer, String) -> Token)
forall b a.
(b -> Token)
-> (b -> Token) -> Either String (b -> Token) -> Lex a (b -> Token)
lexHash (Integer, String) -> Token
IntTok (Integer, String) -> Token
IntTokHash (((Integer, String) -> Token)
-> Either String ((Integer, String) -> Token)
forall a b. b -> Either a b
Right (Integer, String) -> Token
WordTokHash)
case String
s of
[] -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
EOF
Char
'0':Char
c:Char
d:String
_ | Char -> Char
toLower Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'o' Bool -> Bool -> Bool
&& Char -> Bool
isOctDigit Char
d -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
(Integer
n, String
str) <- Lex a (Integer, String)
forall a. Lex a (Integer, String)
lexOctal
(Integer, String) -> Token
con <- Lex a ((Integer, String) -> Token)
forall a. Lex a ((Integer, String) -> Token)
intHash
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer, String) -> Token
con (Integer
n, Char
'0'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
str))
| Char -> Char
toLower Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'b' Bool -> Bool -> Bool
&& Char -> Bool
isBinDigit Char
d Bool -> Bool -> Bool
&& KnownExtension
BinaryLiterals KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
(Integer
n, String
str) <- Lex a (Integer, String)
forall a. Lex a (Integer, String)
lexBinary
(Integer, String) -> Token
con <- Lex a ((Integer, String) -> Token)
forall a. Lex a ((Integer, String) -> Token)
intHash
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer, String) -> Token
con (Integer
n, Char
'0'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
str))
| Char -> Char
toLower Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'x' Bool -> Bool -> Bool
&& Char -> Bool
isHexDigit Char
d -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
(Integer
n, String
str) <- Lex a (Integer, String)
forall a. Lex a (Integer, String)
lexHexadecimal
(Integer, String) -> Token
con <- Lex a ((Integer, String) -> Token)
forall a. Lex a ((Integer, String) -> Token)
intHash
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer, String) -> Token
con (Integer
n, Char
'0'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
str))
Char
'?':Char
c:String
_ | Char -> Bool
isIdentStart Char
c Bool -> Bool -> Bool
&& KnownExtension
ImplicitParams KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
String
id <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ String -> Token
IDupVarId String
id
Char
'%':Char
c:String
_ | Char -> Bool
isIdentStart Char
c Bool -> Bool -> Bool
&& KnownExtension
ImplicitParams KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
String
id <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ String -> Token
ILinVarId String
id
Char
'(':Char
'|':Char
c:String
_ | KnownExtension
RegularPatterns KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isHSymbol Char
c) ->
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RPGuardOpen
| KnownExtension
Arrows KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isHSymbol Char
c) ->
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
OpenArrowBracket
Char
'|':Char
')':String
_ | KnownExtension
RegularPatterns KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RPGuardClose
| KnownExtension
Arrows KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
CloseArrowBracket
Char
'[':Char
'|':Char
'|':String
_ | KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THTExpQuote
Char
'[':Char
'e':Char
'|':Char
'|':String
_ | KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
4
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THTExpQuote
Char
'[':Char
'|':String
_ | KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THExpQuote
Char
'[':Char
c:Char
'|':String
_ | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'e' Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THExpQuote
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'p' Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THPatQuote
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'd' Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THDecQuote
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
't' Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THTypQuote
Char
'[':Char
'$':Char
c:String
_ | Char -> Bool
isIdentStart Char
c Bool -> Bool -> Bool
&& KnownExtension
QuasiQuotes KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts ->
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Token
forall a. Char -> Lex a Token
lexQuasiQuote Char
c
Char
'[':Char
c:String
s' | Char -> Bool
isIdentStart Char
c Bool -> Bool -> Bool
&& KnownExtension
QuasiQuotes KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts Bool -> Bool -> Bool
&& case (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isIdent String
s' of { Char
'|':String
_ -> Bool
True;String
_->Bool
False} ->
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Token
forall a. Char -> Lex a Token
lexQuasiQuote Char
c
| Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
&& KnownExtension
QuasiQuotes KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts Bool -> Bool -> Bool
&& case (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isPossiblyQvar String
s' of { Char
'|':String
_ -> Bool
True;String
_->Bool
False} ->
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a Token
forall a. Char -> Lex a Token
lexQuasiQuote Char
c
Char
'|':Char
'|':Char
']':String
_ | KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THTCloseQuote
Char
'|':Char
']':String
_ | KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THCloseQuote
Char
'$':Char
c1:Char
c2:String
_ | Char -> Bool
isIdentStart Char
c1 Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
String
id <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ String -> Token
THIdEscape String
id
| Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THParenEscape
| Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'$' Bool -> Bool -> Bool
&& Char -> Bool
isIdentStart Char
c2 Bool -> Bool -> Bool
&& KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
String
id <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ String -> Token
THTIdEscape String
id
| Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 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 (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 (m :: * -> *) a. Monad m => a -> m a
return Token
THTParenEscape
Char
'<':Char
'%':Char
c:String
_ | KnownExtension
XmlSyntax KnownExtension -> [KnownExtension] -> 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 (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 (m :: * -> *) a. Monad m => a -> m a
return Token
XCodeTagOpen
Char
'<':Char
c:String
_ | Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
&& KnownExtension
XmlSyntax KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
ExtContext -> Lex a ()
forall a. ExtContext -> Lex a ()
pushExtContextL ExtContext
TagCtxt
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
XStdTagOpen
Char
'(':Char
'#':Char
c:String
_ | [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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
LeftHashParen
Char
'#':Char
')':String
_ | [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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RightHashParen
Char
'{':Char
'-':Char
'#':String
_ -> Lex a ()
forall a. Lex a ()
saveExtensionsL Lex a () -> Lex a () -> Lex a ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Lex a Token
forall a. Lex a Token
lexPragmaStart
Char
'#':Char
'-':Char
'}':String
_ -> Lex a ()
forall a. Lex a ()
restoreExtensionsL Lex a () -> Lex a () -> Lex a ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
PragmaEnd
Char
'[':Char
':':String
_ | KnownExtension
ParallelArrays KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
ParArrayLeftSquare
Char
':':Char
']':String
_ | KnownExtension
ParallelArrays KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
ParArrayRightSquare
Char
'@':Char
c:String
_ | KnownExtension
TypeApplications KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts
Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isOpSymbol Char
c) -> do
Char
lc <- Lex a Char
forall r. Lex r Char
getLastChar
if Char -> Bool
isIdent Char
lc
then Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
At
else Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
TApp
Char
'#':Char
c:String
_ | KnownExtension
OverloadedLabels KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts
Bool -> Bool -> Bool
&& Char -> Bool
isIdentStart Char
c -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
[String
ident] <- Lex a [String]
forall a. Lex a [String]
lexIdents
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ String -> Token
LabelVarId String
ident
Char
c:String
_ | Char -> Bool
isDigit Char
c -> Lex a Token
forall a. Lex a Token
lexDecimalOrFloat
| Char -> Bool
isUpper Char
c -> String -> Lex a Token
forall a. String -> Lex a Token
lexConIdOrQual String
""
| Char -> Bool
isIdentStart Char
c -> do
[String]
idents <- Lex a [String]
forall a. Lex a [String]
lexIdents
case [String]
idents of
[String
ident] -> case String
-> [(String, (Token, Maybe ExtScheme))]
-> Maybe (Token, Maybe ExtScheme)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
ident ([(String, (Token, Maybe ExtScheme))]
reserved_ids [(String, (Token, Maybe ExtScheme))]
-> [(String, (Token, Maybe ExtScheme))]
-> [(String, (Token, Maybe ExtScheme))]
forall a. [a] -> [a] -> [a]
++ [(String, (Token, Maybe ExtScheme))]
special_varids) of
Just (Token
keyword, Maybe ExtScheme
scheme) ->
if Maybe ExtScheme -> [KnownExtension] -> Bool
forall a. Enabled a => a -> [KnownExtension] -> Bool
isEnabled Maybe ExtScheme
scheme [KnownExtension]
exts
then Token -> Lex a ()
forall a. Token -> Lex a ()
flagKW Token
keyword Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
keyword
else Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ String -> Token
VarId String
ident
Maybe (Token, Maybe ExtScheme)
Nothing -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ String -> Token
VarId String
ident
[String]
_ -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ [String] -> Token
DVarId [String]
idents
| Char -> Bool
isHSymbol Char
c -> do
String
sym <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isHSymbol
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ case String
-> [(String, (Token, Maybe ExtScheme))]
-> Maybe (Token, Maybe ExtScheme)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
sym ([(String, (Token, Maybe ExtScheme))]
reserved_ops [(String, (Token, Maybe ExtScheme))]
-> [(String, (Token, Maybe ExtScheme))]
-> [(String, (Token, Maybe ExtScheme))]
forall a. [a] -> [a] -> [a]
++ [(String, (Token, Maybe ExtScheme))]
special_varops) of
Just (Token
t , Maybe ExtScheme
scheme) ->
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
':' -> String -> Token
ConSym String
sym
Char
_ -> String -> Token
VarSym String
sym
Maybe (Token, Maybe ExtScheme)
Nothing -> case Char
c of
Char
':' -> String -> Token
ConSym String
sym
Char
_ -> String -> Token
VarSym String
sym
| Bool
otherwise -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
case Char
c of
Char
'(' -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
LeftParen
Char
')' -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RightParen
Char
',' -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
Comma
Char
';' -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
SemiColon
Char
'[' -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
LeftSquare
Char
']' -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RightSquare
Char
'`' -> Token -> Lex a Token
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 (m :: * -> *) a. Monad m => a -> m a
return Token
LeftCurly
Char
'}' -> do
String -> Lex a ()
forall a. String -> Lex a ()
popContextL String
"lexStdToken"
Token -> Lex a Token
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
_ -> String -> Lex a Token
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Illegal character \'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\'\n")
where lexIdents :: Lex a [String]
lexIdents :: Lex a [String]
lexIdents = do
String
ident <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
String
s <- Lex a String
forall r. Lex r String
getInput
[KnownExtension]
exts <- Lex a [KnownExtension]
forall a. Lex a [KnownExtension]
getExtensionsL
case String
s of
Char
'-':Char
c:String
_ | KnownExtension
XmlSyntax KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts Bool -> Bool -> Bool
&& Char -> Bool
isAlpha Char
c -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
[String]
idents <- Lex a [String]
forall a. Lex a [String]
lexIdents
[String] -> Lex a [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> Lex a [String]) -> [String] -> Lex a [String]
forall a b. (a -> b) -> a -> b
$ String
ident String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
idents
Char
'#':String
_ | KnownExtension
MagicHash KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
String
hashes <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#')
[String] -> Lex a [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
ident String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
hashes]
String
_ -> [String] -> Lex a [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
ident]
lexQuasiQuote :: Char -> Lex a Token
lexQuasiQuote :: Char -> Lex a Token
lexQuasiQuote Char
c = do
String
ident <- Lex a String
forall r. Lex r String
lexQuoter
Char -> String -> Lex a ()
forall a. Char -> String -> Lex a ()
matchChar Char
'|' String
"Malformed quasi-quote quoter"
String
body <- Lex a String
forall r. Lex r String
lexQQBody
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ (String, String) -> Token
THQuasiQuote (String
ident, String
body)
where lexQuoter :: Lex a String
lexQuoter
| Char -> Bool
isIdentStart Char
c = (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
| Bool
otherwise = do
Token
qualThing <- String -> Lex a Token
forall a. String -> Lex a Token
lexConIdOrQual String
""
case Token
qualThing of
QVarId (String
s1,String
s2) -> String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Lex a String) -> String -> Lex a String
forall a b. (a -> b) -> a -> b
$ String
s1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'.'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s2
QVarSym (String
s1, String
s2) -> String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Lex a String) -> String -> Lex a String
forall a b. (a -> b) -> a -> b
$ String
s1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'.'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s2
Token
_ -> String -> Lex a String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Malformed quasi-quote quoter"
lexQQBody :: Lex a String
lexQQBody :: Lex a String
lexQQBody = do
String
s <- Lex a String
forall r. Lex r String
getInput
case String
s of
Char
'\\':Char
']':String
_ -> do Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
String
str <- Lex a String
forall r. Lex r String
lexQQBody
String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
']'Char -> ShowS
forall a. a -> [a] -> [a]
:String
str)
Char
'\\':Char
'|':String
_ -> do Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
String
str <- Lex a String
forall r. Lex r String
lexQQBody
String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'|'Char -> ShowS
forall a. a -> [a] -> [a]
:String
str)
Char
'|':Char
']':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a String -> Lex a String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
Char
'|':String
_ -> do Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
String
str <- Lex a String
forall r. Lex r String
lexQQBody
String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'|'Char -> ShowS
forall a. a -> [a] -> [a]
:String
str)
Char
']':String
_ -> do Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
String
str <- Lex a String
forall r. Lex r String
lexQQBody
String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
']'Char -> ShowS
forall a. a -> [a] -> [a]
:String
str)
Char
'\\':String
_ -> do Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
String
str <- Lex a String
forall r. Lex r String
lexQQBody
String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:String
str)
Char
'\n':String
_ -> do Lex a ()
forall a. Lex a ()
lexNewline
String
str <- Lex a String
forall r. Lex r String
lexQQBody
String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\n'Char -> ShowS
forall a. a -> [a] -> [a]
:String
str)
[] -> String -> Lex a String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected end of input while lexing quasi-quoter"
String
_ -> do String
str <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"\\|\n"))
String
rest <- Lex a String
forall r. Lex r String
lexQQBody
String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
strString -> ShowS
forall a. [a] -> [a] -> [a]
++String
rest)
unboxed :: [KnownExtension] -> Bool
unboxed :: [KnownExtension] -> Bool
unboxed [KnownExtension]
exts = KnownExtension
UnboxedSums KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts Bool -> Bool -> Bool
|| KnownExtension
UnboxedTuples KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts
lookupKnownPragma :: String -> Maybe Token
lookupKnownPragma :: String -> Maybe Token
lookupKnownPragma String
s =
case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s of
String
x | String
"options_" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x -> Token -> Maybe Token
forall a. a -> Maybe a
Just (Token -> Maybe Token) -> Token -> Maybe Token
forall a b. (a -> b) -> a -> b
$ (Maybe String, String) -> Token
OPTIONS (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
8 String
s, String
forall a. HasCallStack => a
undefined)
| String
"options" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
x -> Token -> Maybe Token
forall a. a -> Maybe a
Just (Token -> Maybe Token) -> Token -> Maybe Token
forall a b. (a -> b) -> a -> b
$ (Maybe String, String) -> Token
OPTIONS (Maybe String
forall a. Maybe a
Nothing, String
forall a. HasCallStack => a
undefined)
| Bool
otherwise -> String -> [(String, Token)] -> Maybe Token
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
x [(String, Token)]
pragmas
lexPragmaStart :: Lex a Token
lexPragmaStart :: Lex a Token
lexPragmaStart = do
(Char -> Bool) -> Lex a ()
forall a. (Char -> Bool) -> Lex a ()
lexWhile_ Char -> Bool
isSpace
String
pr <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isPragmaChar
case String -> Maybe Token
lookupKnownPragma String
pr of
Just (INLINE Bool
True) -> do
String
s <- Lex a String
forall r. Lex r String
getInput
case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s of
Char
' ':Char
'c':Char
'o':Char
'n':Char
'l':Char
'i':Char
'k':Char
'e':String
_ -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
8
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
INLINE_CONLIKE
String
_ -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ Bool -> Token
INLINE Bool
True
Just Token
SPECIALISE -> do
String
s <- Lex a String
forall r. Lex r String
getInput
case (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s of
Char
'i':Char
'n':Char
'l':Char
'i':Char
'n':Char
'e':String
_ -> 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 (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':String
_ -> 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 (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':String
_ -> 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 (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
String
_ -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
SPECIALISE
Just (OPTIONS (Maybe String, String)
opt) ->
let dropIfSpace :: ShowS
dropIfSpace (Char
' ':String
xs) = String
xs
dropIfSpace String
xs = String
xs
in
case (Maybe String, String) -> Maybe String
forall a b. (a, b) -> a
fst (Maybe String, String)
opt of
Just String
opt' -> do
String
rest <- Lex a String
forall r. Lex r String
lexRawPragma
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ (Maybe String, String) -> Token
OPTIONS (String -> Maybe String
forall a. a -> Maybe a
Just String
opt', ShowS
dropIfSpace String
rest)
Maybe String
Nothing -> do
String
s <- Lex a String
forall r. Lex r String
getInput
case String
s of
Char
x:String
_ | Char -> Bool
isSpace Char
x -> do
String
rest <- Lex a String
forall r. Lex r String
lexRawPragma
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ (Maybe String, String) -> Token
OPTIONS (Maybe String
forall a. Maybe a
Nothing, ShowS
dropIfSpace String
rest)
String
_ -> String -> Lex a Token
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Malformed Options pragma"
Just Token
RULES -> do
KnownExtension -> Lex a ()
forall a. KnownExtension -> Lex a ()
addExtensionL KnownExtension
ScopedTypeVariables
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
RULES
Just Token
p -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
p
Maybe Token
_ -> String -> Lex a Token
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Internal error: Unrecognised recognised pragma"
lexRawPragma :: Lex a String
lexRawPragma :: Lex a String
lexRawPragma = Lex a String
forall r. Lex r String
lexRawPragmaAux
where lexRawPragmaAux :: Lex a String
lexRawPragmaAux = do
String
rpr <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'#')
String
s <- Lex a String
forall r. Lex r String
getInput
case String
s of
Char
'#':Char
'-':Char
'}':String
_ -> String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return String
rpr
String
"" -> String -> Lex a String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"End-of-file inside pragma"
String
_ -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
String
rpr' <- Lex a String
forall r. Lex r String
lexRawPragma
String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Lex a String) -> String -> Lex a String
forall a b. (a -> b) -> a -> b
$ String
rpr String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'#'Char -> ShowS
forall a. a -> [a] -> [a]
:String
rpr'
lexDecimalOrFloat :: Lex a Token
lexDecimalOrFloat :: Lex a Token
lexDecimalOrFloat = do
String
ds <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isDigit
String
rest <- Lex a String
forall r. Lex r String
getInput
[KnownExtension]
exts <- Lex a [KnownExtension]
forall a. Lex a [KnownExtension]
getExtensionsL
case String
rest of
(Char
'.':Char
d:String
_) | Char -> Bool
isDigit Char
d -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
String
frac <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isDigit
let num :: Integer
num = Integer -> String -> Integer
parseInteger Integer
10 (String
ds String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
frac)
decimals :: Integer
decimals = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
frac)
(Integer
exponent, String
estr) <- do
String
rest2 <- Lex a String
forall r. Lex r String
getInput
case String
rest2 of
Char
'e':String
_ -> Lex a (Integer, String)
forall a. Lex a (Integer, String)
lexExponent
Char
'E':String
_ -> Lex a (Integer, String)
forall a. Lex a (Integer, String)
lexExponent
String
_ -> (Integer, String) -> Lex a (Integer, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
0,String
"")
(Rational, String) -> Token
con <- ((Rational, String) -> Token)
-> ((Rational, String) -> Token)
-> Either String ((Rational, String) -> Token)
-> Lex a ((Rational, String) -> Token)
forall b a.
(b -> Token)
-> (b -> Token) -> Either String (b -> Token) -> Lex a (b -> Token)
lexHash (Rational, String) -> Token
FloatTok (Rational, String) -> Token
FloatTokHash (((Rational, String) -> Token)
-> Either String ((Rational, String) -> Token)
forall a b. b -> Either a b
Right (Rational, String) -> Token
DoubleTokHash)
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ (Rational, String) -> Token
con ((Integer
numInteger -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
1) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
10Rational -> Integer -> Rational
forall a b. (Fractional a, Integral b) => a -> b -> a
^^(Integer
exponent Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
decimals), String
ds String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'.'Char -> ShowS
forall a. a -> [a] -> [a]
:String
frac String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
estr)
Char
e:String
_ | Char -> Char
toLower Char
e Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'e' -> do
(Integer
exponent, String
estr) <- Lex a (Integer, String)
forall a. Lex a (Integer, String)
lexExponent
(Rational, String) -> Token
con <- ((Rational, String) -> Token)
-> ((Rational, String) -> Token)
-> Either String ((Rational, String) -> Token)
-> Lex a ((Rational, String) -> Token)
forall b a.
(b -> Token)
-> (b -> Token) -> Either String (b -> Token) -> Lex a (b -> Token)
lexHash (Rational, String) -> Token
FloatTok (Rational, String) -> Token
FloatTokHash (((Rational, String) -> Token)
-> Either String ((Rational, String) -> Token)
forall a b. b -> Either a b
Right (Rational, String) -> Token
DoubleTokHash)
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ (Rational, String) -> Token
con ((Integer -> String -> Integer
parseInteger Integer
10 String
dsInteger -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
1) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
10Rational -> Integer -> Rational
forall a b. (Fractional a, Integral b) => a -> b -> a
^^Integer
exponent, String
ds String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
estr)
Char
'#':Char
'#':String
_ | KnownExtension
MagicHash KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer, String) -> Token
WordTokHash (Integer -> String -> Integer
parseInteger Integer
10 String
ds, String
ds))
Char
'#':String
_ | KnownExtension
MagicHash KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer, String) -> Token
IntTokHash (Integer -> String -> Integer
parseInteger Integer
10 String
ds, String
ds))
String
_ -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return ((Integer, String) -> Token
IntTok (Integer -> String -> Integer
parseInteger Integer
10 String
ds, String
ds))
where
lexExponent :: Lex a (Integer, String)
lexExponent :: Lex a (Integer, String)
lexExponent = do
(Char
e:String
r) <- Lex a String
forall r. Lex r String
getInput
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
case String
r of
Char
'+':Char
d:String
_ | Char -> Bool
isDigit Char
d -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
(Integer
n, String
str) <- Lex a (Integer, String)
forall a. Lex a (Integer, String)
lexDecimal
(Integer, String) -> Lex a (Integer, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
n, Char
eChar -> ShowS
forall a. a -> [a] -> [a]
:Char
'+'Char -> ShowS
forall a. a -> [a] -> [a]
:String
str)
Char
'-':Char
d:String
_ | Char -> Bool
isDigit Char
d -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
(Integer
n, String
str) <- Lex a (Integer, String)
forall a. Lex a (Integer, String)
lexDecimal
(Integer, String) -> Lex a (Integer, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Integer
forall a. Num a => a -> a
negate Integer
n, Char
eChar -> ShowS
forall a. a -> [a] -> [a]
:Char
'-'Char -> ShowS
forall a. a -> [a] -> [a]
:String
str)
Char
d:String
_ | Char -> Bool
isDigit Char
d -> Lex a (Integer, String)
forall a. Lex a (Integer, String)
lexDecimal Lex a (Integer, String)
-> ((Integer, String) -> Lex a (Integer, String))
-> Lex a (Integer, String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Integer
n,String
str) -> (Integer, String) -> Lex a (Integer, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
n, Char
eChar -> ShowS
forall a. a -> [a] -> [a]
:String
str)
String
_ -> String -> Lex a (Integer, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Float with missing exponent"
lexHash :: (b -> Token) -> (b -> Token) -> Either String (b -> Token) -> Lex a (b -> Token)
lexHash :: (b -> Token)
-> (b -> Token) -> Either String (b -> Token) -> Lex a (b -> Token)
lexHash b -> Token
a b -> Token
b Either String (b -> Token)
c = do
[KnownExtension]
exts <- Lex a [KnownExtension]
forall a. Lex a [KnownExtension]
getExtensionsL
if KnownExtension
MagicHash KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts
then do
String
r <- Lex a String
forall r. Lex r String
getInput
case String
r of
Char
'#':Char
'#':String
_ -> case Either String (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (b -> Token) -> Lex a (b -> Token)
forall (m :: * -> *) a. Monad m => a -> m a
return b -> Token
c'
Left String
s -> String -> Lex a (b -> Token)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
s
Char
'#':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a (b -> Token) -> Lex a (b -> Token)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (b -> Token) -> Lex a (b -> Token)
forall (m :: * -> *) a. Monad m => a -> m a
return b -> Token
b
String
_ -> (b -> Token) -> Lex a (b -> Token)
forall (m :: * -> *) a. Monad m => a -> m a
return b -> Token
a
else (b -> Token) -> Lex a (b -> Token)
forall (m :: * -> *) a. Monad m => a -> m a
return b -> Token
a
lexConIdOrQual :: String -> Lex a Token
lexConIdOrQual :: String -> Lex a Token
lexConIdOrQual String
qual = do
String
con <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
let conid :: Token
conid | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
qual = String -> Token
ConId String
con
| Bool
otherwise = (String, String) -> Token
QConId (String
qual,String
con)
qual' :: String
qual' | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
qual = String
con
| Bool
otherwise = String
qual String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'.'Char -> ShowS
forall a. a -> [a] -> [a]
:String
con
Lex a Token
just_a_conid <- Lex a Token -> Lex a (Lex a Token)
forall a v. Lex a v -> Lex a (Lex a v)
alternative (Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
conid)
String
rest <- Lex a String
forall r. Lex r String
getInput
[KnownExtension]
exts <- Lex a [KnownExtension]
forall a. Lex a [KnownExtension]
getExtensionsL
case String
rest of
Char
'.':Char
c:String
_
| Char -> Bool
isIdentStart Char
c -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
String
ident <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isIdent
String
s <- Lex a String
forall r. Lex r String
getInput
[KnownExtension]
exts' <- Lex a [KnownExtension]
forall a. Lex a [KnownExtension]
getExtensionsL
String
ident' <- case String
s of
Char
'#':String
_ | KnownExtension
MagicHash KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts' -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a String -> Lex a String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
ident String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"#")
String
_ -> String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return String
ident
case String
-> [(String, (Token, Maybe ExtScheme))]
-> Maybe (Token, Maybe ExtScheme)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
ident' [(String, (Token, Maybe ExtScheme))]
reserved_ids of
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 (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> Token
QVarId (String
qual', String
ident'))
| Char -> Bool
isUpper Char
c -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
String -> Lex a Token
forall a. String -> Lex a Token
lexConIdOrQual String
qual'
| Char -> Bool
isHSymbol Char
c -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
String
sym <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isHSymbol
[KnownExtension]
exts' <- Lex a [KnownExtension]
forall a. Lex a [KnownExtension]
getExtensionsL
case String
-> [(String, (Token, Maybe ExtScheme))]
-> Maybe (Token, Maybe ExtScheme)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
sym [(String, (Token, Maybe ExtScheme))]
reserved_ops of
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 (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ case Char
c of
Char
':' -> (String, String) -> Token
QConSym (String
qual', String
sym)
Char
_ -> (String, String) -> Token
QVarSym (String
qual', String
sym)
Char
'#':String
cs
| String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
cs Bool -> Bool -> Bool
||
Bool -> Bool
not (Char -> Bool
isHSymbol (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Char
forall a. [a] -> a
head String
cs) Bool -> Bool -> Bool
&&
Bool -> Bool
not (Char -> Bool
isIdent (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Char
forall a. [a] -> a
head String
cs) Bool -> Bool -> Bool
&& KnownExtension
MagicHash KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
case Token
conid of
ConId String
con' -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ String -> Token
ConId (String -> Token) -> String -> Token
forall a b. (a -> b) -> a -> b
$ String
con' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"#"
QConId (String
q,String
con') -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return (Token -> Lex a Token) -> Token -> Lex a Token
forall a b. (a -> b) -> a -> b
$ (String, String) -> Token
QConId (String
q,String
con' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"#")
Token
_ -> String -> Lex a Token
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Lex a Token) -> String -> Lex a Token
forall a b. (a -> b) -> a -> b
$ String
"lexConIdOrQual: unexpected token: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Token -> String
forall a. Show a => a -> String
show Token
conid
String
_ -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
conid
lexCharacter :: Lex a Token
lexCharacter :: Lex a Token
lexCharacter = do
String
s <- Lex a String
forall r. Lex r String
getInput
[KnownExtension]
exts <- Lex a [KnownExtension]
forall a. Lex a [KnownExtension]
getExtensionsL
case String
s of
Char
'\'':String
_ | KnownExtension
TemplateHaskell KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a Token -> Lex a Token
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THTyQuote
Char
'\\':String
_ -> do
(Char
c,String
raw) <- Lex a (Char, String)
forall a. Lex a (Char, String)
lexEscape
Lex a ()
forall a. Lex a ()
matchQuote
(Char, String) -> Token
con <- ((Char, String) -> Token)
-> ((Char, String) -> Token)
-> Either String ((Char, String) -> Token)
-> Lex a ((Char, String) -> Token)
forall b a.
(b -> Token)
-> (b -> Token) -> Either String (b -> Token) -> Lex a (b -> Token)
lexHash (Char, String) -> Token
Character (Char, String) -> Token
CharacterHash
(String -> Either String ((Char, String) -> Token)
forall a b. a -> Either a b
Left String
"Double hash not available for character literals")
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return ((Char, String) -> Token
con (Char
c, Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:String
raw))
Char
c:Char
'\'':String
_ -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2
(Char, String) -> Token
con <- ((Char, String) -> Token)
-> ((Char, String) -> Token)
-> Either String ((Char, String) -> Token)
-> Lex a ((Char, String) -> Token)
forall b a.
(b -> Token)
-> (b -> Token) -> Either String (b -> Token) -> Lex a (b -> Token)
lexHash (Char, String) -> Token
Character (Char, String) -> Token
CharacterHash
(String -> Either String ((Char, String) -> Token)
forall a b. a -> Either a b
Left String
"Double hash not available for character literals")
Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return ((Char, String) -> Token
con (Char
c, [Char
c]))
String
_ | (KnownExtension -> Bool) -> [KnownExtension] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts) [KnownExtension
TemplateHaskell, KnownExtension
DataKinds] -> Token -> Lex a Token
forall (m :: * -> *) a. Monad m => a -> m a
return Token
THVarQuote
String
_ -> String -> Lex a Token
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Improper character constant or misplaced \'"
where matchQuote :: Lex a ()
matchQuote = Char -> String -> Lex a ()
forall a. Char -> String -> Lex a ()
matchChar Char
'\'' String
"Improperly terminated character constant"
lexString :: Lex a Token
lexString :: Lex a Token
lexString = (String, String) -> Lex a Token
forall r. (String, String) -> Lex r Token
loop (String
"",String
"")
where
loop :: (String, String) -> Lex r Token
loop (String
s,String
raw) = do
String
r <- Lex r String
forall r. Lex r String
getInput
[KnownExtension]
exts <- Lex r [KnownExtension]
forall a. Lex a [KnownExtension]
getExtensionsL
case String
r of
Char
'\\':Char
'&':String
_ -> do
Int -> Lex r ()
forall r. Int -> Lex r ()
discard Int
2
(String, String) -> Lex r Token
loop (String
s, Char
'&'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:String
raw)
Char
'\\':Char
c:String
_ | Char -> Bool
isSpace Char
c -> do
Int -> Lex r ()
forall r. Int -> Lex r ()
discard Int
1
String
wcs <- Lex r String
forall r. Lex r String
lexWhiteChars
Char -> String -> Lex r ()
forall a. Char -> String -> Lex a ()
matchChar Char
'\\' String
"Illegal character in string gap"
(String, String) -> Lex r Token
loop (String
s, Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
forall a. [a] -> [a]
reverse String
wcs String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:String
raw)
| Bool
otherwise -> do
(Char
ce, String
str) <- Lex r (Char, String)
forall a. Lex a (Char, String)
lexEscape
(String, String) -> Lex r Token
loop (Char
ceChar -> ShowS
forall a. a -> [a] -> [a]
:String
s, ShowS
forall a. [a] -> [a]
reverse String
str String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'\\'Char -> ShowS
forall a. a -> [a] -> [a]
:String
raw)
Char
'"':Char
'#':String
_ | KnownExtension
MagicHash KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts -> do
Int -> Lex r ()
forall r. Int -> Lex r ()
discard Int
2
Token -> Lex r Token
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> Token
StringHash (ShowS
forall a. [a] -> [a]
reverse String
s, ShowS
forall a. [a] -> [a]
reverse String
raw))
Char
'"':String
_ -> do
Int -> Lex r ()
forall r. Int -> Lex r ()
discard Int
1
Token -> Lex r Token
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> Token
StringTok (ShowS
forall a. [a] -> [a]
reverse String
s, ShowS
forall a. [a] -> [a]
reverse String
raw))
Char
c:String
_ | 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
(String, String) -> Lex r Token
loop (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
s, Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
raw)
String
_ -> String -> Lex r Token
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Improperly terminated string"
lexWhiteChars :: Lex a String
lexWhiteChars :: Lex a String
lexWhiteChars = do
String
s <- Lex a String
forall r. Lex r String
getInput
case String
s of
Char
'\n':String
_ -> do
Lex a ()
forall a. Lex a ()
lexNewline
String
wcs <- Lex a String
forall r. Lex r String
lexWhiteChars
String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Lex a String) -> String -> Lex a String
forall a b. (a -> b) -> a -> b
$ Char
'\n'Char -> ShowS
forall a. a -> [a] -> [a]
:String
wcs
Char
'\t':String
_ -> do
Lex a ()
forall a. Lex a ()
lexTab
String
wcs <- Lex a String
forall r. Lex r String
lexWhiteChars
String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Lex a String) -> String -> Lex a String
forall a b. (a -> b) -> a -> b
$ Char
'\t'Char -> ShowS
forall a. a -> [a] -> [a]
:String
wcs
Char
c:String
_ | Char -> Bool
isSpace Char
c -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
String
wcs <- Lex a String
forall r. Lex r String
lexWhiteChars
String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Lex a String) -> String -> Lex a String
forall a b. (a -> b) -> a -> b
$ Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
wcs
String
_ -> String -> Lex a String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
lexEscape :: Lex a (Char, String)
lexEscape :: Lex a (Char, String)
lexEscape = do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
String
r <- Lex a String
forall r. Lex r String
getInput
case String
r of
Char
'a':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\a', String
"a")
Char
'b':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\b', String
"b")
Char
'f':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\f', String
"f")
Char
'n':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\n', String
"n")
Char
'r':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\r', String
"r")
Char
't':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\t', String
"t")
Char
'v':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\v', String
"v")
Char
'\\':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\\', String
"\\")
Char
'"':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\"', String
"\"")
Char
'\'':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\'', String
"\'")
Char
'^':Char
c:String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Lex a (Char, String)
forall a. Char -> Lex a (Char, String)
cntrl Char
c
Char
'N':Char
'U':Char
'L':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\NUL', String
"NUL")
Char
'S':Char
'O':Char
'H':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\SOH', String
"SOH")
Char
'S':Char
'T':Char
'X':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\STX', String
"STX")
Char
'E':Char
'T':Char
'X':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\ETX', String
"ETX")
Char
'E':Char
'O':Char
'T':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\EOT', String
"EOT")
Char
'E':Char
'N':Char
'Q':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\ENQ', String
"ENQ")
Char
'A':Char
'C':Char
'K':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\ACK', String
"ACK")
Char
'B':Char
'E':Char
'L':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\BEL', String
"BEL")
Char
'B':Char
'S':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\BS', String
"BS")
Char
'H':Char
'T':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\HT', String
"HT")
Char
'L':Char
'F':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\LF', String
"LF")
Char
'V':Char
'T':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\VT', String
"VT")
Char
'F':Char
'F':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\FF', String
"FF")
Char
'C':Char
'R':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\CR', String
"CR")
Char
'S':Char
'O':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\SO', String
"SO")
Char
'S':Char
'I':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\SI', String
"SI")
Char
'D':Char
'L':Char
'E':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\DLE', String
"DLE")
Char
'D':Char
'C':Char
'1':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\DC1', String
"DC1")
Char
'D':Char
'C':Char
'2':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\DC2', String
"DC2")
Char
'D':Char
'C':Char
'3':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\DC3', String
"DC3")
Char
'D':Char
'C':Char
'4':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\DC4', String
"DC4")
Char
'N':Char
'A':Char
'K':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\NAK', String
"NAK")
Char
'S':Char
'Y':Char
'N':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\SYN', String
"SYN")
Char
'E':Char
'T':Char
'B':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\ETB', String
"ETB")
Char
'C':Char
'A':Char
'N':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\CAN', String
"CAN")
Char
'E':Char
'M':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\EM', String
"EM")
Char
'S':Char
'U':Char
'B':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\SUB', String
"SUB")
Char
'E':Char
'S':Char
'C':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\ESC', String
"ESC")
Char
'F':Char
'S':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\FS', String
"FS")
Char
'G':Char
'S':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\GS', String
"GS")
Char
'R':Char
'S':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\RS', String
"RS")
Char
'U':Char
'S':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\US', String
"US")
Char
'S':Char
'P':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
2 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\SP', String
"SP")
Char
'D':Char
'E':Char
'L':String
_ -> Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
3 Lex a () -> Lex a (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
'\DEL', String
"DEL")
Char
'o':Char
c:String
_ | Char -> Bool
isOctDigit Char
c -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
(Integer
n, String
raw) <- Lex a (Integer, String)
forall a. Lex a (Integer, String)
lexOctal
Char
n' <- Integer -> Lex a Char
forall (m :: * -> *). MonadFail m => Integer -> m Char
checkChar Integer
n
(Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
n', Char
'o'Char -> ShowS
forall a. a -> [a] -> [a]
:String
raw)
Char
'x':Char
c:String
_ | Char -> Bool
isHexDigit Char
c -> do
Int -> Lex a ()
forall r. Int -> Lex r ()
discard Int
1
(Integer
n, String
raw) <- Lex a (Integer, String)
forall a. Lex a (Integer, String)
lexHexadecimal
Char
n' <- Integer -> Lex a Char
forall (m :: * -> *). MonadFail m => Integer -> m Char
checkChar Integer
n
(Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
n', Char
'x'Char -> ShowS
forall a. a -> [a] -> [a]
:String
raw)
Char
c:String
_ | Char -> Bool
isDigit Char
c -> do
(Integer
n, String
raw) <- Lex a (Integer, String)
forall a. Lex a (Integer, String)
lexDecimal
Char
n' <- Integer -> Lex a Char
forall (m :: * -> *). MonadFail m => Integer -> m Char
checkChar Integer
n
(Char, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
n', String
raw)
String
_ -> String -> Lex a (Char, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal escape sequence"
where
checkChar :: Integer -> m Char
checkChar Integer
n | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0x10FFFF = Char -> m Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n))
checkChar Integer
_ = String -> m Char
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Character constant out of range"
cntrl :: Char -> Lex a (Char, String)
cntrl :: Char -> Lex a (Char, String)
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, String) -> Lex a (Char, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'@'), Char
'^'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:[])
cntrl Char
_ = String -> Lex a (Char, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal control character"
lexOctal :: Lex a (Integer, String)
lexOctal :: Lex a (Integer, String)
lexOctal = do
String
ds <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isOctDigit
(Integer, String) -> Lex a (Integer, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> String -> Integer
parseInteger Integer
8 String
ds, String
ds)
lexBinary :: Lex a (Integer, String)
lexBinary :: Lex a (Integer, String)
lexBinary = do
String
ds <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isBinDigit
(Integer, String) -> Lex a (Integer, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> String -> Integer
parseInteger Integer
2 String
ds, String
ds)
lexHexadecimal :: Lex a (Integer, String)
lexHexadecimal :: Lex a (Integer, String)
lexHexadecimal = do
String
ds <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isHexDigit
(Integer, String) -> Lex a (Integer, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> String -> Integer
parseInteger Integer
16 String
ds, String
ds)
lexDecimal :: Lex a (Integer, String)
lexDecimal :: Lex a (Integer, String)
lexDecimal = do
String
ds <- (Char -> Bool) -> Lex a String
forall a. (Char -> Bool) -> Lex a String
lexWhile Char -> Bool
isDigit
(Integer, String) -> Lex a (Integer, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> String -> Integer
parseInteger Integer
10 String
ds, String
ds)
parseInteger :: Integer -> String -> Integer
parseInteger :: Integer -> String -> Integer
parseInteger Integer
radix String
ds =
(Integer -> Integer -> Integer) -> [Integer] -> Integer
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Integer
n Integer
d -> Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
radix Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
d) ((Char -> Integer) -> String -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> (Char -> Int) -> Char -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
digitToInt) String
ds)
flagKW :: Token -> Lex a ()
flagKW :: 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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Token
KW_Do, Token
KW_MDo]) (Lex a () -> Lex a ()) -> Lex a () -> Lex a ()
forall a b. (a -> b) -> a -> b
$ do
[KnownExtension]
exts <- Lex a [KnownExtension]
forall a. Lex a [KnownExtension]
getExtensionsL
Bool -> Lex a () -> Lex a ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KnownExtension
NondecreasingIndentation KnownExtension -> [KnownExtension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KnownExtension]
exts) Lex a ()
forall a. Lex a ()
flagDo
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'
showToken :: Token -> String
showToken :: Token -> String
showToken Token
t = case Token
t of
VarId String
s -> String
s
LabelVarId String
s -> Char
'#'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s
QVarId (String
q,String
s) -> String
q String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'.'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s
IDupVarId String
s -> Char
'?'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s
ILinVarId String
s -> Char
'%'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s
ConId String
s -> String
s
QConId (String
q,String
s) -> String
q String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'.'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s
DVarId [String]
ss -> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" [String]
ss
VarSym String
s -> String
s
ConSym String
s -> String
s
QVarSym (String
q,String
s) -> String
q String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'.'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s
QConSym (String
q,String
s) -> String
q String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'.'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s
IntTok (Integer
_, String
s) -> String
s
FloatTok (Rational
_, String
s) -> String
s
Character (Char
_, String
s) -> Char
'\''Char -> ShowS
forall a. a -> [a] -> [a]
:String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'"
StringTok (String
_, String
s) -> Char
'"'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\""
IntTokHash (Integer
_, String
s) -> String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"#"
WordTokHash (Integer
_, String
s) -> String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"##"
FloatTokHash (Rational
_, String
s) -> String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"#"
DoubleTokHash (Rational
_, String
s) -> String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"##"
CharacterHash (Char
_, String
s) -> Char
'\''Char -> ShowS
forall a. a -> [a] -> [a]
:String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'#"
StringHash (String
_, String
s) -> Char
'"'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\"#"
Token
LeftParen -> String
"("
Token
RightParen -> String
")"
Token
LeftHashParen -> String
"(#"
Token
RightHashParen -> String
"#)"
Token
SemiColon -> String
";"
Token
LeftCurly -> String
"{"
Token
RightCurly -> String
"}"
Token
VRightCurly -> String
"virtual }"
Token
LeftSquare -> String
"["
Token
RightSquare -> String
"]"
Token
ParArrayLeftSquare -> String
"[:"
Token
ParArrayRightSquare -> String
":]"
Token
Comma -> String
","
Token
Underscore -> String
"_"
Token
BackQuote -> String
"`"
Token
QuoteColon -> String
"':"
Token
Dot -> String
"."
Token
DotDot -> String
".."
Token
Colon -> String
":"
Token
DoubleColon -> String
"::"
Token
Equals -> String
"="
Token
Backslash -> String
"\\"
Token
Bar -> String
"|"
Token
LeftArrow -> String
"<-"
Token
RightArrow -> String
"->"
Token
At -> String
"@"
Token
TApp -> String
"@"
Token
Tilde -> String
"~"
Token
DoubleArrow -> String
"=>"
Token
Minus -> String
"-"
Token
Exclamation -> String
"!"
Token
Star -> String
"*"
Token
LeftArrowTail -> String
"-<"
Token
RightArrowTail -> String
">-"
Token
LeftDblArrowTail -> String
"-<<"
Token
RightDblArrowTail -> String
">>-"
Token
OpenArrowBracket -> String
"(|"
Token
CloseArrowBracket -> String
"|)"
Token
THExpQuote -> String
"[|"
Token
THTExpQuote -> String
"[||"
Token
THPatQuote -> String
"[p|"
Token
THDecQuote -> String
"[d|"
Token
THTypQuote -> String
"[t|"
Token
THCloseQuote -> String
"|]"
Token
THTCloseQuote -> String
"||]"
THIdEscape String
s -> Char
'$'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s
Token
THParenEscape -> String
"$("
THTIdEscape String
s -> String
"$$" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
Token
THTParenEscape -> String
"$$("
Token
THVarQuote -> String
"'"
Token
THTyQuote -> String
"''"
THQuasiQuote (String
n,String
q) -> String
"[$" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"|" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
q String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
Token
RPGuardOpen -> String
"(|"
Token
RPGuardClose -> String
"|)"
Token
RPCAt -> String
"@:"
Token
XCodeTagOpen -> String
"<%"
Token
XCodeTagClose -> String
"%>"
Token
XStdTagOpen -> String
"<"
Token
XStdTagClose -> String
">"
Token
XCloseTagOpen -> String
"</"
Token
XEmptyTagClose -> String
"/>"
XPCDATA String
s -> String
"PCDATA " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
Token
XRPatOpen -> String
"<["
Token
XRPatClose -> String
"]>"
Token
PragmaEnd -> String
"#-}"
Token
RULES -> String
"{-# RULES"
INLINE Bool
b -> String
"{-# " String -> ShowS
forall a. [a] -> [a] -> [a]
++ if Bool
b then String
"INLINE" else String
"NOINLINE"
Token
INLINE_CONLIKE -> String
"{-# " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"INLINE CONLIKE"
Token
SPECIALISE -> String
"{-# SPECIALISE"
SPECIALISE_INLINE Bool
b -> String
"{-# SPECIALISE " String -> ShowS
forall a. [a] -> [a] -> [a]
++ if Bool
b then String
"INLINE" else String
"NOINLINE"
Token
SOURCE -> String
"{-# SOURCE"
Token
DEPRECATED -> String
"{-# DEPRECATED"
Token
WARNING -> String
"{-# WARNING"
Token
SCC -> String
"{-# SCC"
Token
GENERATED -> String
"{-# GENERATED"
Token
CORE -> String
"{-# CORE"
Token
UNPACK -> String
"{-# UNPACK"
Token
NOUNPACK -> String
"{-# NOUNPACK"
OPTIONS (Maybe String
mt,String
_) -> String
"{-# OPTIONS" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (Char
':'Char -> ShowS
forall a. a -> [a] -> [a]
:) Maybe String
mt String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ..."
Token
LANGUAGE -> String
"{-# LANGUAGE"
Token
ANN -> String
"{-# ANN"
Token
MINIMAL -> String
"{-# MINIMAL"
Token
NO_OVERLAP -> String
"{-# NO_OVERLAP"
Token
OVERLAP -> String
"{-# OVERLAP"
Token
OVERLAPPING -> String
"{-# OVERLAPPING"
Token
OVERLAPPABLE -> String
"{-# OVERLAPPABLE"
Token
OVERLAPS -> String
"{-# OVERLAPS"
Token
INCOHERENT -> String
"{-# INCOHERENT"
Token
COMPLETE -> String
"{-# COMPLETE"
Token
KW_As -> String
"as"
Token
KW_By -> String
"by"
Token
KW_Case -> String
"case"
Token
KW_Class -> String
"class"
Token
KW_Data -> String
"data"
Token
KW_Default -> String
"default"
Token
KW_Deriving -> String
"deriving"
Token
KW_Do -> String
"do"
Token
KW_MDo -> String
"mdo"
Token
KW_Else -> String
"else"
Token
KW_Family -> String
"family"
Token
KW_Forall -> String
"forall"
Token
KW_Group -> String
"group"
Token
KW_Hiding -> String
"hiding"
Token
KW_If -> String
"if"
Token
KW_Import -> String
"import"
Token
KW_In -> String
"in"
Token
KW_Infix -> String
"infix"
Token
KW_InfixL -> String
"infixl"
Token
KW_InfixR -> String
"infixr"
Token
KW_Instance -> String
"instance"
Token
KW_Let -> String
"let"
Token
KW_Module -> String
"module"
Token
KW_NewType -> String
"newtype"
Token
KW_Of -> String
"of"
Token
KW_Proc -> String
"proc"
Token
KW_Rec -> String
"rec"
Token
KW_Then -> String
"then"
Token
KW_Type -> String
"type"
Token
KW_Using -> String
"using"
Token
KW_Where -> String
"where"
Token
KW_Qualified -> String
"qualified"
Token
KW_Foreign -> String
"foreign"
Token
KW_Export -> String
"export"
Token
KW_Safe -> String
"safe"
Token
KW_Unsafe -> String
"unsafe"
Token
KW_Threadsafe -> String
"threadsafe"
Token
KW_Interruptible -> String
"interruptible"
Token
KW_StdCall -> String
"stdcall"
Token
KW_CCall -> String
"ccall"
Token
XChildTagOpen -> String
"<%>"
Token
KW_CPlusPlus -> String
"cplusplus"
Token
KW_DotNet -> String
"dotnet"
Token
KW_Jvm -> String
"jvm"
Token
KW_Js -> String
"js"
Token
KW_JavaScript -> String
"javascript"
Token
KW_CApi -> String
"capi"
Token
KW_Role -> String
"role"
Token
KW_Pattern -> String
"pattern"
Token
KW_Stock -> String
"stock"
Token
KW_Anyclass -> String
"anyclass"
Token
KW_Via -> String
"via"
Token
EOF -> String
"EOF"