#include "HsVersions.h"
-import Char ( toUpper )
+import Char ( toUpper, isDigit, chr, ord )
+import Ratio ( (%) )
import PrelNames ( mkTupNameStr )
import ForeignCall ( Safety(..) )
import FastString
import StringBuffer
-import GlaExts
import Ctype
-import Char ( chr, ord )
-import Bits ( Bits(..) ) -- non-std
-
-#if __GLASGOW_HASKELL__ >= 503
-import GHC.Read ( readRational__ ) -- Glasgow non-std
-#else
-import PrelRead ( readRational__ ) -- Glasgow non-std
-#endif
-import Int ( Int32 )
+import GLAEXTS
+import DATA_BITS ( Bits(..) )
+import DATA_INT ( Int32 )
\end{code}
%************************************************************************
| ITccallconv
| ITdotnet
| ITccall (Bool,Bool,Safety) -- (is_dyn, is_casm, may_gc)
+ | ITmdo
| ITspecialise_prag -- Pragmas
| ITsource_prag
| ITdeprecated_prag
| ITline_prag
| ITscc_prag
+ | ITcore_prag -- hdaume: core annotations
| ITclose_prag
| ITdotdot -- reserved symbols
+ | ITcolon
| ITdcolon
| ITequal
| ITlam
| ITunderscore
| ITbackquote
- | ITvarid FAST_STRING -- identifiers
- | ITconid FAST_STRING
- | ITvarsym FAST_STRING
- | ITconsym FAST_STRING
- | ITqvarid (FAST_STRING,FAST_STRING)
- | ITqconid (FAST_STRING,FAST_STRING)
- | ITqvarsym (FAST_STRING,FAST_STRING)
- | ITqconsym (FAST_STRING,FAST_STRING)
+ | ITvarid FastString -- identifiers
+ | ITconid FastString
+ | ITvarsym FastString
+ | ITconsym FastString
+ | ITqvarid (FastString,FastString)
+ | ITqconid (FastString,FastString)
+ | ITqvarsym (FastString,FastString)
+ | ITqconsym (FastString,FastString)
- | ITdupipvarid FAST_STRING -- GHC extension: implicit param: ?x
- | ITsplitipvarid FAST_STRING -- GHC extension: implicit param: %x
+ | ITdupipvarid FastString -- GHC extension: implicit param: ?x
+ | ITsplitipvarid FastString -- GHC extension: implicit param: %x
| ITpragma StringBuffer
| ITchar Int
- | ITstring FAST_STRING
+ | ITstring FastString
| ITinteger Integer
| ITrational Rational
| ITprimchar Int
- | ITprimstring FAST_STRING
+ | ITprimstring FastString
| ITprimint Integer
| ITprimfloat Rational
| ITprimdouble Rational
- | ITlitlit FAST_STRING
+ | ITlitlit FastString
+
+ -- MetaHaskell extension tokens
+ | ITopenExpQuote -- [| or [e|
+ | ITopenPatQuote -- [p|
+ | ITopenDecQuote -- [d|
+ | ITopenTypQuote -- [t|
+ | ITcloseQuote -- |]
+ | ITidEscape FastString -- $x
+ | ITparenEscape -- $(
+ | ITreifyType
+ | ITreifyDecl
+ | ITreifyFixity
+
+ -- Arrow notation extension
+ | ITproc
+ | ITrec
+ | IToparenbar -- (|
+ | ITcparenbar -- |)
+ | ITlarrowtail -- -<
+ | ITrarrowtail -- >-
+ | ITLarrowtail -- -<<
+ | ITRarrowtail -- >>-
| ITunknown String -- Used when the lexer can't make sense of it
| ITeof -- end of file token
\begin{code}
pragmaKeywordsFM = listToUFM $
- map (\ (x,y) -> (_PK_ x,y))
+ map (\ (x,y) -> (mkFastString x,y))
[( "SPECIALISE", ITspecialise_prag ),
( "SPECIALIZE", ITspecialise_prag ),
( "SOURCE", ITsource_prag ),
( "RULES", ITrules_prag ),
( "RULEZ", ITrules_prag ), -- american spelling :-)
( "SCC", ITscc_prag ),
+ ( "CORE", ITcore_prag ), -- hdaume: core annotation
( "DEPRECATED", ITdeprecated_prag )
]
haskellKeywordsFM = listToUFM $
- map (\ (x,y) -> (_PK_ x,y))
+ map (\ (x,y) -> (mkFastString x,y))
[( "_", ITunderscore ),
( "as", ITas ),
( "case", ITcase ),
isSpecial ITwith = True
isSpecial ITccallconv = True
isSpecial ITstdcallconv = True
+isSpecial ITmdo = True
isSpecial _ = False
--- IMPORTANT: Keep this in synch with ParseIface.y's var_fs production! (SUP)
+-- the bitmap provided as the third component indicates whether the
+-- corresponding extension keyword is valid under the extension options
+-- provided to the compiler; if the extension corresponding to *any* of the
+-- bits set in the bitmap is enabled, the keyword is valid (this setup
+-- facilitates using a keyword in two different extensions that can be
+-- activated independently)
+--
ghcExtensionKeywordsFM = listToUFM $
- map (\ (x,y) -> (_PK_ x,y))
- [ ( "forall", ITforall ),
- ( "foreign", ITforeign ),
- ( "export", ITexport ),
- ( "label", ITlabel ),
- ( "dynamic", ITdynamic ),
- ( "safe", ITsafe ),
- ( "threadsafe", ITthreadsafe ),
- ( "unsafe", ITunsafe ),
- ( "with", ITwith ),
- ( "stdcall", ITstdcallconv),
- ( "ccall", ITccallconv),
- ( "dotnet", ITdotnet),
- ("_ccall_", ITccall (False, False, PlayRisky)),
- ("_ccall_GC_", ITccall (False, False, PlaySafe False)),
- ("_casm_", ITccall (False, True, PlayRisky)),
- ("_casm_GC_", ITccall (False, True, PlaySafe False))
+ map (\(x, y, z) -> (mkFastString x, (y, z)))
+ [ ( "forall", ITforall, bit glaExtsBit),
+ ( "mdo", ITmdo, bit glaExtsBit),
+ ( "reifyDecl", ITreifyDecl, bit glaExtsBit),
+ ( "reifyType", ITreifyType, bit glaExtsBit),
+ ( "reifyFixity",ITreifyFixity, bit glaExtsBit),
+
+ ( "foreign", ITforeign, bit ffiBit),
+ ( "export", ITexport, bit ffiBit),
+ ( "label", ITlabel, bit ffiBit),
+ ( "dynamic", ITdynamic, bit ffiBit),
+ ( "safe", ITsafe, bit ffiBit),
+ ( "threadsafe", ITthreadsafe, bit ffiBit),
+ ( "unsafe", ITunsafe, bit ffiBit),
+ ( "stdcall", ITstdcallconv, bit ffiBit),
+ ( "ccall", ITccallconv, bit ffiBit),
+ ( "dotnet", ITdotnet, bit ffiBit),
+
+ ( "with", ITwith, bit withBit),
+
+ ( "rec", ITrec, bit arrowsBit),
+ ( "proc", ITproc, bit arrowsBit),
+
+ -- On death row
+ ("_ccall_", ITccall (False, False, PlayRisky),
+ bit glaExtsBit),
+ ("_ccall_GC_", ITccall (False, False, PlaySafe False),
+ bit glaExtsBit),
+ ("_casm_", ITccall (False, True, PlayRisky),
+ bit glaExtsBit),
+ ("_casm_GC_", ITccall (False, True, PlaySafe False),
+ bit glaExtsBit)
]
-
haskellKeySymsFM = listToUFM $
- map (\ (x,y) -> (_PK_ x,y))
- [ ("..", ITdotdot)
- ,("::", ITdcolon)
- ,("=", ITequal)
- ,("\\", ITlam)
- ,("|", ITvbar)
- ,("<-", ITlarrow)
- ,("->", ITrarrow)
- ,("@", ITat)
- ,("~", ITtilde)
- ,("=>", ITdarrow)
- ,("-", ITminus)
- ,("!", ITbang)
- ,("*", ITstar)
- ,(".", ITdot) -- sadly, for 'forall a . t'
+ map (\ (x,y,z) -> (mkFastString x,(y,z)))
+ [ ("..", ITdotdot, Nothing)
+ ,(":", ITcolon, Nothing) -- (:) is a reserved op,
+ -- meaning only list cons
+ ,("::", ITdcolon, Nothing)
+ ,("=", ITequal, Nothing)
+ ,("\\", ITlam, Nothing)
+ ,("|", ITvbar, Nothing)
+ ,("<-", ITlarrow, Nothing)
+ ,("->", ITrarrow, Nothing)
+ ,("@", ITat, Nothing)
+ ,("~", ITtilde, Nothing)
+ ,("=>", ITdarrow, Nothing)
+ ,("-", ITminus, Nothing)
+ ,("!", ITbang, Nothing)
+
+ ,("*", ITstar, Just (bit glaExtsBit)) -- For data T (a::*) = MkT
+ ,(".", ITdot, Just (bit glaExtsBit)) -- For 'forall a . t'
+
+ ,("-<", ITlarrowtail, Just (bit arrowsBit))
+ ,(">-", ITrarrowtail, Just (bit arrowsBit))
+ ,("-<<", ITLarrowtail, Just (bit arrowsBit))
+ ,(">>-", ITRarrowtail, Just (bit arrowsBit))
]
+
\end{code}
-----------------------------------------------------------------------------
-- processing if necessary).
'{'# | lookAhead# buf 1# `eqChar#` '-'# ->
if lookAhead# buf 2# `eqChar#` '#'# then
- case expandWhile# is_space (setCurrentPos# buf 3#) of { buf1->
+ case expandWhile# is_space (addToCurrentPos buf 3#) of { buf1->
case expandWhile# is_ident (stepOverLexeme buf1) of { buf2->
let lexeme = mkFastString -- ToDo: too slow
(map toUpper (lexemeToString buf2)) in
case currentChar# buf of
-- special symbols ----------------------------------------------------
- '('# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '#'#
- -> cont IToubxparen (setCurrentPos# buf 2#)
+ '('# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '#'# &&
+ -- Unboxed tules: '(#' but not '(##'
+ not (lookAhead# buf 2# `eqChar#` '#'#)
+ -> cont IToubxparen (addToCurrentPos buf 2#)
+ -- Arrow notation extension: '(|' but not '(||'
+ | arrowsEnabled exts && lookAhead# buf 1# `eqChar#` '|'# &&
+ not (lookAhead# buf 2# `eqChar#` '|'#)
+ -> cont IToparenbar (addToCurrentPos buf 2#)
| otherwise
- -> cont IToparen (incLexeme buf)
+ -> cont IToparen (incCurrentPos buf)
- ')'# -> cont ITcparen (incLexeme buf)
+ ')'# -> cont ITcparen (incCurrentPos buf)
'['# | parrEnabled exts && lookAhead# buf 1# `eqChar#` ':'# ->
- cont ITopabrack (setCurrentPos# buf 2#)
- | otherwise ->
- cont ITobrack (incLexeme buf)
- ']'# -> cont ITcbrack (incLexeme buf)
- ','# -> cont ITcomma (incLexeme buf)
- ';'# -> cont ITsemi (incLexeme buf)
+ cont ITopabrack (addToCurrentPos buf 2#)
+ ------- MetaHaskell Extensions, looking for [| [e| [t| [p| and [d|
+ | glaExtsEnabled exts &&
+ ((lookAhead# buf 1# ) `eqChar#` '|'# ) ->
+ cont ITopenExpQuote (addToCurrentPos buf 2# )
+ | glaExtsEnabled exts &&
+ (let c = (lookAhead# buf 1# )
+ in eqChar# c 'e'# || eqChar# c 't'# || eqChar# c 'd'# || eqChar# c 'p'#) &&
+ ((lookAhead# buf 2#) `eqChar#` '|'#) ->
+ let quote 'e'# = ITopenExpQuote
+ quote 'p'# = ITopenPatQuote
+ quote 'd'# = ITopenDecQuote
+ quote 't'# = ITopenTypQuote
+ in cont (quote (lookAhead# buf 1#)) (addToCurrentPos buf 3# )
+ | otherwise ->
+ cont ITobrack (incCurrentPos buf)
+
+ ']'# -> cont ITcbrack (incCurrentPos buf)
+ ','# -> cont ITcomma (incCurrentPos buf)
+ ';'# -> cont ITsemi (incCurrentPos buf)
'}'# -> \ s@PState{context = ctx} ->
case ctx of
- (_:ctx') -> cont ITccurly (incLexeme buf) s{context=ctx'}
+ (_:ctx') -> cont ITccurly (incCurrentPos buf) s{context=ctx'}
_ -> lexError "too many '}'s" buf s
'|'# -> case lookAhead# buf 1# of
'}'# | glaExtsEnabled exts -> cont ITccurlybar
- (setCurrentPos# buf 2#)
- _ -> lex_sym cont (incLexeme buf)
+ (addToCurrentPos buf 2#)
+ -- MetaHaskell extension
+ ']'# | glaExtsEnabled exts -> cont ITcloseQuote (addToCurrentPos buf 2#)
+ -- arrow notation extension
+ ')'# | arrowsEnabled exts -> cont ITcparenbar
+ (addToCurrentPos buf 2#)
+ other -> lex_sym cont exts (incCurrentPos buf)
':'# -> case lookAhead# buf 1# of
']'# | parrEnabled exts -> cont ITcpabrack
- (setCurrentPos# buf 2#)
- _ -> lex_sym cont (incLexeme buf)
+ (addToCurrentPos buf 2#)
+ _ -> lex_sym cont exts (incCurrentPos buf)
'#'# -> case lookAhead# buf 1# of
')'# | glaExtsEnabled exts
- -> cont ITcubxparen (setCurrentPos# buf 2#)
+ -> cont ITcubxparen (addToCurrentPos buf 2#)
'-'# -> case lookAhead# buf 2# of
- '}'# -> cont ITclose_prag (setCurrentPos# buf 3#)
- _ -> lex_sym cont (incLexeme buf)
- _ -> lex_sym cont (incLexeme buf)
+ '}'# -> cont ITclose_prag (addToCurrentPos buf 3#)
+ _ -> lex_sym cont exts (incCurrentPos buf)
+ _ -> lex_sym cont exts (incCurrentPos buf)
'`'# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '`'#
- -> lex_cstring cont (setCurrentPos# buf 2#)
+ -> lex_cstring cont (addToCurrentPos buf 2#)
| otherwise
- -> cont ITbackquote (incLexeme buf)
+ -> cont ITbackquote (incCurrentPos buf)
'{'# -> -- for Emacs: -}
case lookAhead# buf 1# of
'|'# | glaExtsEnabled exts
- -> cont ITocurlybar (setCurrentPos# buf 2#)
+ -> cont ITocurlybar (addToCurrentPos buf 2#)
'-'# -> case lookAhead# buf 2# of
- '#'# -> lex_prag cont (setCurrentPos# buf 3#)
- _ -> cont ITocurly (incLexeme buf)
- _ -> (layoutOff `thenP_` cont ITocurly) (incLexeme buf)
+ '#'# -> lex_prag cont (addToCurrentPos buf 3#)
+ _ -> cont ITocurly (incCurrentPos buf)
+ _ -> (layoutOff `thenP_` cont ITocurly) (incCurrentPos buf)
+
+
+
-- strings/characters -------------------------------------------------
- '\"'#{-"-} -> lex_string cont exts [] (incLexeme buf)
- '\''# -> lex_char (char_end cont) exts (incLexeme buf)
+ '\"'#{-"-} -> lex_string cont exts [] (incCurrentPos buf)
+ '\''# -> lex_char (char_end cont) exts (incCurrentPos buf)
-- Hexadecimal and octal constants
'0'# | (ch `eqChar#` 'x'# || ch `eqChar#` 'X'#) && is_hexdigit ch2
-> readNum (after_lexnum cont exts) buf' is_octdigit 8 oct_or_dec
where ch = lookAhead# buf 1#
ch2 = lookAhead# buf 2#
- buf' = setCurrentPos# buf 2#
+ buf' = addToCurrentPos buf 2#
'\NUL'# ->
if bufferExhausted (stepOn buf) then
trace "lexIface: misplaced NUL?" $
cont (ITunknown "\NUL") (stepOn buf)
- '?'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) ->
- lex_ip ITdupipvarid cont (incLexeme buf)
+ '?'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> -- ?x implicit parameter
+ specialPrefixId ITdupipvarid cont exts (incCurrentPos buf)
'%'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) ->
- lex_ip ITsplitipvarid cont (incLexeme buf)
+ specialPrefixId ITsplitipvarid cont exts (incCurrentPos buf)
+
+ ---------------- MetaHaskell Extensions for quotation escape
+ '$'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> -- $x variable escape
+ specialPrefixId ITidEscape cont exts (addToCurrentPos buf 1#)
+ '$'# | glaExtsEnabled exts && -- $( f x ) expression escape
+ ((lookAhead# buf 1#) `eqChar#` '('#) -> cont ITparenEscape (addToCurrentPos buf 2#)
+
c | is_digit c -> lex_num cont exts 0 buf
- | is_symbol c -> lex_sym cont buf
+ | is_symbol c -> lex_sym cont exts buf
| is_upper c -> lex_con cont exts buf
- | is_ident c -> lex_id cont exts buf
+ | is_lower c -> lex_id cont exts buf
| otherwise -> lexError "illegal character" buf
-- Int# is unlifted, and therefore faster than Bool for flags.
lex_string cont exts s buf
= case currentChar# buf of
'"'#{-"-} ->
- let buf' = incLexeme buf
- s' = mkFastStringNarrow (map chr (reverse s))
+ let buf' = incCurrentPos buf
in case currentChar# buf' of
- '#'# | glaExtsEnabled exts -> if all (<= 0xFF) s
- then cont (ITprimstring s') (incLexeme buf')
- else lexError "primitive string literal must contain only characters <= \'\\xFF\'" buf'
- _ -> cont (ITstring s') buf'
+ '#'# | glaExtsEnabled exts ->
+ if any (> 0xFF) s
+ then lexError "primitive string literal must contain only characters <= \'\\xFF\'" buf'
+ else let s' = mkFastStringNarrow (map chr (reverse s)) in
+ -- always a narrow string/byte array
+ cont (ITprimstring s') (incCurrentPos buf')
+
+ _other -> let s' = mkFastString (map chr (reverse s))
+ in cont (ITstring s') buf'
-- ignore \& in a string, deal with string gaps
'\\'# | next_ch `eqChar#` '&'#
-> lex_string cont exts s buf'
| is_space next_ch
- -> lex_stringgap cont exts s (incLexeme buf)
+ -> lex_stringgap cont exts s (incCurrentPos buf)
where next_ch = lookAhead# buf 1#
- buf' = setCurrentPos# buf 2#
+ buf' = addToCurrentPos buf 2#
_ -> lex_char (lex_next_string cont s) exts buf
lex_stringgap cont exts s buf
- = let buf' = incLexeme buf in
+ = let buf' = incCurrentPos buf in
case currentChar# buf of
'\n'# -> \st@PState{loc = loc} -> lex_stringgap cont exts s buf'
st{loc = incSrcLine loc}
lex_char :: (Int# -> Int -> P a) -> Int# -> P a
lex_char cont exts buf
= case currentChar# buf of
- '\\'# -> lex_escape (cont exts) (incLexeme buf)
- c | is_any c -> cont exts (I# (ord# c)) (incLexeme buf)
+ '\\'# -> lex_escape (cont exts) (incCurrentPos buf)
+ c | is_any c -> cont exts (I# (ord# c)) (incCurrentPos buf)
other -> charError buf
char_end cont exts c buf
= case currentChar# buf of
- '\''# -> let buf' = incLexeme buf in
+ '\''# -> let buf' = incCurrentPos buf in
case currentChar# buf' of
'#'# | glaExtsEnabled exts
- -> cont (ITprimchar c) (incLexeme buf')
+ -> cont (ITprimchar c) (incCurrentPos buf')
_ -> cont (ITchar c) buf'
_ -> charError buf
lex_escape cont buf
- = let buf' = incLexeme buf in
+ = let buf' = incCurrentPos buf in
case currentChar# buf of
'a'# -> cont (ord '\a') buf'
'b'# -> cont (ord '\b') buf'
'\''# -> cont (ord '\'') buf'
'^'# -> let c = currentChar# buf' in
if c `geChar#` '@'# && c `leChar#` '_'#
- then cont (I# (ord# c -# ord# '@'#)) (incLexeme buf')
+ then cont (I# (ord# c -# ord# '@'#)) (incCurrentPos buf')
else charError buf'
'x'# -> readNum (after_charnum cont) buf' is_hexdigit 16 hex
where read buf i
= case currentChar# buf of { c ->
if is_digit c
- then read (incLexeme buf) (i*base + (toInteger (I# (conv c))))
+ then read (incCurrentPos buf) (i*base + (toInteger (I# (conv c))))
else cont i buf
}
-- this case is not optimised at all, as the
-- presence of floating point numbers in interface
-- files is not that common. (ToDo)
- case expandWhile# is_digit (incLexeme buf') of
+ case expandWhile# is_digit (incCurrentPos buf') of
buf2 -> -- points to first non digit char
-
- let l = case currentChar# buf2 of
- 'E'# -> do_exponent
- 'e'# -> do_exponent
- _ -> buf2
-
- do_exponent
- = let buf3 = incLexeme buf2 in
- case currentChar# buf3 of
- '-'# | is_digit (lookAhead# buf3 1#)
- -> expandWhile# is_digit (incLexeme buf3)
- '+'# | is_digit (lookAhead# buf3 1#)
- -> expandWhile# is_digit (incLexeme buf3)
- x | is_digit x -> expandWhile# is_digit buf3
- _ -> buf2
-
- v = readRational__ (lexemeToString l)
-
- in case currentChar# l of -- glasgow exts only
- '#'# | glaExtsEnabled exts -> let l' = incLexeme l in
- case currentChar# l' of
- '#'# -> cont (ITprimdouble v) (incLexeme l')
- _ -> cont (ITprimfloat v) l'
- _ -> cont (ITrational v) l
-
- _ -> after_lexnum cont exts acc' buf'
+ case currentChar# buf2 of
+ 'E'# -> float_exponent cont exts buf2
+ 'e'# -> float_exponent cont exts buf2
+ _ -> float_done cont exts buf2
+
+ -- numbers like '9e4' are floats
+ 'E'# -> float_exponent cont exts buf'
+ 'e'# -> float_exponent cont exts buf'
+ _ -> after_lexnum cont exts acc' buf' -- it's an integer
+float_exponent cont exts buf2 =
+ let buf3 = incCurrentPos buf2
+ buf4 = case currentChar# buf3 of
+ '-'# | is_digit (lookAhead# buf3 1#)
+ -> expandWhile# is_digit (incCurrentPos buf3)
+ '+'# | is_digit (lookAhead# buf3 1#)
+ -> expandWhile# is_digit (incCurrentPos buf3)
+ x | is_digit x -> expandWhile# is_digit buf3
+ _ -> buf2
+ in
+ float_done cont exts buf4
+
+float_done cont exts buf =
+ case currentChar# buf of -- glasgow exts only
+ '#'# | glaExtsEnabled exts ->
+ let buf' = incCurrentPos buf in
+ case currentChar# buf' of
+ '#'# -> cont (ITprimdouble v) (incCurrentPos buf')
+ _ -> cont (ITprimfloat v) buf'
+ _ -> cont (ITrational v) buf
+ where
+ v = readRational__ (lexemeToString buf)
+
after_lexnum cont exts i buf
= case currentChar# buf of
- '#'# | glaExtsEnabled exts -> cont (ITprimint i) (incLexeme buf)
+ '#'# | glaExtsEnabled exts -> cont (ITprimint i) (incCurrentPos buf)
_ -> cont (ITinteger i) buf
+readRational :: ReadS Rational -- NB: doesn't handle leading "-"
+readRational r = do
+ (n,d,s) <- readFix r
+ (k,t) <- readExp s
+ return ((n%1)*10^^(k-d), t)
+ where
+ readFix r = do
+ (ds,s) <- lexDecDigits r
+ (ds',t) <- lexDotDigits s
+ return (read (ds++ds'), length ds', t)
+
+ readExp (e:s) | e `elem` "eE" = readExp' s
+ readExp s = return (0,s)
+
+ readExp' ('+':s) = readDec s
+ readExp' ('-':s) = do
+ (k,t) <- readDec s
+ return (-k,t)
+ readExp' s = readDec s
+
+ readDec s = do
+ (ds,r) <- nonnull isDigit s
+ return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
+ r)
+
+ lexDecDigits = nonnull isDigit
+
+ lexDotDigits ('.':s) = return (span isDigit s)
+ lexDotDigits s = return ("",s)
+
+ nonnull p s = do (cs@(_:_),t) <- return (span p s)
+ return (cs,t)
+
+readRational__ :: String -> Rational -- NB: *does* handle a leading "-"
+readRational__ top_s
+ = case top_s of
+ '-' : xs -> - (read_me xs)
+ xs -> read_me xs
+ where
+ read_me s
+ = case (do { (x,"") <- readRational s ; return x }) of
+ [x] -> x
+ [] -> error ("readRational__: no parse:" ++ top_s)
+ _ -> error ("readRational__: ambiguous parse:" ++ top_s)
+
-----------------------------------------------------------------------------
-- C "literal literal"s (i.e. things like ``NULL'', ``stdout'' etc.)
lex_cstring cont buf =
case expandUntilMatch (stepOverLexeme buf) "\'\'" of
Just buf' -> cont (ITlitlit (lexemeToFastString
- (setCurrentPos# buf' (negateInt# 2#))))
+ (addToCurrentPos buf' (negateInt# 2#))))
(mergeLexemes buf buf')
Nothing -> lexError "unterminated ``" buf
-----------------------------------------------------------------------------
-- identifiers, symbols etc.
-lex_ip ip_constr cont buf =
+-- used for identifiers with special prefixes like
+-- ?x (implicit parameters), $x (MetaHaskell escapes) and #x
+-- we've already seen the prefix char, so look for an id, and wrap
+-- the new "ip_constr" around the lexeme returned
+
+specialPrefixId ip_constr cont exts buf = lex_id newcont exts buf
+ where newcont (ITvarid lexeme) buf2 = cont (ip_constr (tailFS lexeme)) buf2
+ newcont token buf2 = cont token buf2
+{-
case expandWhile# is_ident buf of
buf' -> cont (ip_constr (tailFS lexeme)) buf'
where lexeme = lexemeToFastString buf'
+-}
lex_id cont exts buf =
let buf1 = expandWhile# is_ident buf in
let lexeme = lexemeToFastString buf' in
case _scc_ "haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
- Just kwd_token -> --trace ("hkeywd: "++_UNPK_(lexeme)) $
+ Just kwd_token -> --trace ("hkeywd: "++unpackFS(lexeme)) $
cont kwd_token buf';
Nothing ->
let var_token = cont (ITvarid lexeme) buf' in
- if not (glaExtsEnabled exts)
- then var_token
- else
-
case lookupUFM ghcExtensionKeywordsFM lexeme of {
- Just kwd_token -> cont kwd_token buf';
- Nothing -> var_token
+ Just (kwd_token, validExts)
+ | validExts .&. (toInt32 exts) /= 0 -> cont kwd_token buf';
+ _ -> var_token
}}}
-lex_sym cont buf =
+lex_sym cont exts buf =
-- trace "lex_sym" $
case expandWhile# is_symbol buf of
buf' -> case lookupUFM haskellKeySymsFM lexeme of {
- Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $
- cont kwd_token buf' ;
- Nothing -> --trace ("sym: "++unpackFS lexeme) $
- cont (mk_var_token lexeme) buf'
+ Just (kwd_token, Nothing)
+ -> cont kwd_token buf' ;
+ Just (kwd_token, Just validExts)
+ | validExts .&. toInt32 exts /= 0
+ -> cont kwd_token buf' ;
+ other -> cont (mk_var_token lexeme) buf'
}
where lexeme = lexemeToFastString buf'
let all_buf = mergeLexemes buf con_buf
con_lexeme = lexemeToFastString con_buf
- mod_lexeme = lexemeToFastString (decLexeme buf)
+ mod_lexeme = lexemeToFastString (decCurrentPos buf)
all_lexeme = lexemeToFastString all_buf
just_a_conid
case currentChar# all_buf of
'.'# -> maybe_qualified cont exts all_lexeme
- (incLexeme all_buf) just_a_conid
+ (incCurrentPos all_buf) just_a_conid
_ -> just_a_conid
}}
case currentChar# buf of
'['# -> -- Special case for []
case lookAhead# buf 1# of
- ']'# -> cont (ITqconid (mod,SLIT("[]"))) (setCurrentPos# buf 2#)
+ ']'# -> cont (ITqconid (mod,FSLIT("[]"))) (addToCurrentPos buf 2#)
_ -> just_a_conid
'('# -> -- Special case for (,,,)
-- This *is* necessary to deal with e.g. "instance C PrelBase.(,,)"
case lookAhead# buf 1# of
'#'# | glaExtsEnabled exts -> case lookAhead# buf 2# of
- ','# -> lex_ubx_tuple cont mod (setCurrentPos# buf 3#)
+ ','# -> lex_ubx_tuple cont mod (addToCurrentPos buf 3#)
just_a_conid
_ -> just_a_conid
- ')'# -> cont (ITqconid (mod,SLIT("()"))) (setCurrentPos# buf 2#)
- ','# -> lex_tuple cont mod (setCurrentPos# buf 2#) just_a_conid
+ ')'# -> cont (ITqconid (mod,FSLIT("()"))) (addToCurrentPos buf 2#)
+ ','# -> lex_tuple cont mod (addToCurrentPos buf 2#) just_a_conid
_ -> just_a_conid
'-'# -> case lookAhead# buf 1# of
- '>'# -> cont (ITqconid (mod,SLIT("(->)"))) (setCurrentPos# buf 2#)
+ '>'# -> cont (ITqconid (mod,FSLIT("(->)"))) (addToCurrentPos buf 2#)
_ -> lex_id3 cont exts mod buf just_a_conid
_ -> lex_id3 cont exts mod buf just_a_conid
| f `eqChar#` ':'# = ITconsym pk_str
| otherwise = ITvarsym pk_str
where
- (C# f) = _HEAD_ pk_str
+ (C# f) = headFS pk_str
-- tl = _TAIL_ pk_str
mk_qvar_token m token =
POk _ a -> POk s a
PFailed e -> PFailed e
-getSrcFile :: P FAST_STRING
+getSrcFile :: P FastString
getSrcFile buf s@(PState{ loc = loc }) = POk s (srcLocFile loc)
pushContext :: LayoutContext -> P ()
glaExtsBit, ffiBit, parrBit :: Int
glaExtsBit = 0
-ffiBit = 1 -- FIXME: not used yet; still part of `glaExtsBit'
+ffiBit = 1
parrBit = 2
+withBit = 3
+arrowsBit = 4
glaExtsEnabled, ffiEnabled, parrEnabled :: Int# -> Bool
glaExtsEnabled flags = testBit (toInt32 flags) glaExtsBit
ffiEnabled flags = testBit (toInt32 flags) ffiBit
+withEnabled flags = testBit (toInt32 flags) withBit
parrEnabled flags = testBit (toInt32 flags) parrBit
+arrowsEnabled flags = testBit (toInt32 flags) arrowsBit
toInt32 :: Int# -> Int32
toInt32 x# = fromIntegral (I# x#)
-- convenient record-based bitmap for the interface to the rest of the world
--
+-- NB: `glasgowExtsEF' implies `ffiEF' (see `mkPState' below)
+--
data ExtFlags = ExtFlags {
glasgowExtsEF :: Bool,
--- ffiEF :: Bool, -- commented out to avoid warnings
- parrEF :: Bool -- while not used yet
+ ffiEF :: Bool,
+ withEF :: Bool,
+ parrEF :: Bool,
+ arrowsEF :: Bool
}
-- create a parse state
--
mkPState :: SrcLoc -> ExtFlags -> PState
-mkPState loc exts = PState {
- loc = loc,
- extsBitmap = case (fromIntegral bitmap) of {I# bits -> bits},
- bol = 0#,
- atbol = 1#,
- context = []
- }
- where
- bitmap = glaExtsBit `setBitIf` glasgowExtsEF exts
--- .|. ffiBit `setBitIf` ffiEF exts
- .|. parrBit `setBitIf` parrEF exts
- --
- setBitIf :: Int -> Bool -> Int32
- b `setBitIf` cond | cond = bit b
- | otherwise = 0
+mkPState loc exts =
+ PState {
+ loc = loc,
+ extsBitmap = case (fromIntegral bitmap) of {I# bits -> bits},
+ bol = 0#,
+ atbol = 1#,
+ context = []
+ }
+ where
+ bitmap = glaExtsBit `setBitIf` glasgowExtsEF exts
+ .|. ffiBit `setBitIf` (ffiEF exts
+ || glasgowExtsEF exts)
+ .|. withBit `setBitIf` withEF exts
+ .|. parrBit `setBitIf` parrEF exts
+ .|. arrowsBit `setBitIf` arrowsEF exts
+ --
+ setBitIf :: Int -> Bool -> Int32
+ b `setBitIf` cond | cond = bit b
+ | otherwise = 0
-----------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff