import StringBuffer
import GlaExts
import Ctype
-import Char ( chr, ord )
+import Char ( ord )
import PrelRead ( readRational__ ) -- Glasgow non-std
\end{code}
| ITccallconv
| ITinterface -- interface keywords
+ | ITexpr
| IT__export
| ITdepends
| IT__forall
| ITocurly -- special symbols
| ITccurly
+ | ITocurlybar -- {|, for type applications
+ | ITccurlybar -- |}, for type applications
| ITvccurly
| ITobrack
| ITcbrack
( "_scc_", ITscc )
]
+isSpecial :: Token -> Bool
+-- If we see M.x, where x is a keyword, but
+-- is special, we treat is as just plain M.x,
+-- not as a keyword.
+isSpecial ITas = True
+isSpecial IThiding = True
+isSpecial ITqualified = True
+isSpecial ITforall = True
+isSpecial ITexport = True
+isSpecial ITlabel = True
+isSpecial ITdynamic = True
+isSpecial ITunsafe = True
+isSpecial ITwith = True
+isSpecial ITccallconv = True
+isSpecial ITstdcallconv = True
+isSpecial _ = False
+
-- IMPORTANT: Keep this in synch with ParseIface.y's var_fs production! (SUP)
ghcExtensionKeywordsFM = listToUFM $
map (\ (x,y) -> (_PK_ x,y))
-- interface keywords
("__interface", ITinterface),
+ ("__expr", ITexpr),
("__export", IT__export),
("__depends", ITdepends),
("__forall", IT__forall),
where
line = srcLocLine loc
- tab y bol atbol buf = --trace ("tab: " ++ show (I# y) ++ " : " ++ show (currentChar buf)) $
+ tab y bol atbol buf = -- trace ("tab: " ++ show (I# y) ++ " : " ++ show (currentChar buf)) $
case currentChar# buf of
'\NUL'# ->
-- and throw out any unrecognised pragmas as comments. Any
-- pragmas we know about are dealt with later (after any layout
-- processing if necessary).
-
- '{'# | lookAhead# buf 1# `eqChar#` '-'# ->
+ '{'# | lookAhead# buf 1# `eqChar#` '-'# ->
if lookAhead# buf 2# `eqChar#` '#'# then
if lookAhead# buf 3# `eqChar#` '#'# then is_a_token else
case expandWhile# is_space (setCurrentPos# buf 3#) of { buf1->
loop buf =
case currentChar# buf of
'\NUL'# | bufferExhausted (stepOn buf) ->
- lexError "unterminated `{-'" buf
-
+ lexError "unterminated `{-'" buf -- -}
'-'# | lookAhead# buf 1# `eqChar#` '}'# ->
cont (stepOnBy# buf 2#)
lexToken :: (Token -> P a) -> Int# -> P a
lexToken cont glaexts buf =
- --trace "lexToken" $
+ -- trace "lexToken" $
case currentChar# buf of
-- special symbols ----------------------------------------------------
']'# -> cont ITcbrack (incLexeme buf)
','# -> cont ITcomma (incLexeme buf)
';'# -> cont ITsemi (incLexeme buf)
-
'}'# -> \ s@PState{context = ctx} ->
case ctx of
(_:ctx') -> cont ITccurly (incLexeme buf) s{context=ctx'}
_ -> lexError "too many '}'s" buf s
+ '|'# -> case lookAhead# buf 1# of
+ '}'# | flag glaexts -> cont ITccurlybar
+ (setCurrentPos# buf 2#)
+ _ -> lex_sym cont (incLexeme buf)
+
'#'# -> case lookAhead# buf 1# of
')'# | flag glaexts -> cont ITcubxparen (setCurrentPos# buf 2#)
'-'# -> case lookAhead# buf 2# of
-> cont ITbackquote (incLexeme buf)
'{'# -> -- look for "{-##" special iface pragma
- case lookAhead# buf 1# of
+ case lookAhead# buf 1# of
+ '|'# | flag glaexts
+ -> cont ITocurlybar (setCurrentPos# buf 2#)
'-'# -> case lookAhead# buf 2# of
'#'# -> case lookAhead# buf 3# of
- '#'# ->
+ '#'# ->
let (lexeme, buf')
- = doDiscard False (stepOnBy# (stepOverLexeme buf) 4#) in
- cont (ITpragma lexeme) buf'
+ = doDiscard 0# (stepOnBy# (stepOverLexeme buf) 4#) in
+ cont (ITpragma lexeme) buf'
_ -> lex_prag cont (setCurrentPos# buf 3#)
- _ -> cont ITocurly (incLexeme buf)
- _ -> (layoutOff `thenP_` cont ITocurly) (incLexeme buf)
+ _ -> cont ITocurly (incLexeme buf)
+ _ -> (layoutOff `thenP_` cont ITocurly) (incLexeme buf)
-- strings/characters -------------------------------------------------
'\"'#{-"-} -> lex_string cont glaexts [] (incLexeme buf)
}}}
lex_sym cont buf =
+ -- trace "lex_sym" $
case expandWhile# is_symbol buf of
buf' -> case lookupUFM haskellKeySymsFM lexeme of {
Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $
lex_con cont glaexts buf =
+ -- trace ("con: "{-++unpackFS lexeme-}) $
case expandWhile# is_ident buf of { buf1 ->
case slurp_trailing_hashes buf1 glaexts of { buf' ->
_ -> just_a_conid
where
- just_a_conid = --trace ("con: "++unpackFS lexeme) $
- cont (ITconid lexeme) buf'
+ just_a_conid = cont (ITconid lexeme) buf'
lexeme = lexemeToFastString buf'
munch = lex_qid cont glaexts lexeme (incLexeme buf') just_a_conid
}}
lex_qid cont glaexts mod buf just_a_conid =
+ -- trace ("quid: "{-++unpackFS lexeme-}) $
case currentChar# buf of
'['# -> -- Special case for []
case lookAhead# buf 1# of
let
start_new_lexeme = stepOverLexeme buf
in
+ -- trace ("lex_id31 "{-++unpackFS lexeme-}) $
case expandWhile# is_symbol start_new_lexeme of { buf' ->
let
lexeme = lexemeToFastString buf'
let
start_new_lexeme = stepOverLexeme buf
in
+ -- trace ("lex_id32 "{-++unpackFS lexeme-}) $
case expandWhile# is_ident start_new_lexeme of { buf1 ->
if emptyLexeme buf1
then just_a_conid
case slurp_trailing_hashes buf1 glaexts of { buf' ->
let
- lexeme = lexemeToFastString buf'
- new_buf = mergeLexemes buf buf'
+ lexeme = lexemeToFastString buf'
+ new_buf = mergeLexemes buf buf'
is_a_qvarid = cont (mk_qvar_token mod lexeme) new_buf
in
case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
- Just kwd_token -> just_a_conid; -- avoid M.where etc.
- Nothing -> is_a_qvarid
- -- TODO: special ids (as, qualified, hiding) shouldn't be
- -- recognised as keywords here. ie. M.as is a qualified varid.
- }}}
+ Nothing -> is_a_qvarid ;
+ Just kwd_token | isSpecial kwd_token -- special ids (as, qualified, hiding) shouldn't be
+ -> is_a_qvarid -- recognised as keywords here.
+ | otherwise
+ -> just_a_conid -- avoid M.where etc.
+ }}}
slurp_trailing_hashes buf glaexts
| flag glaexts = expandWhile# (`eqChar#` '#'#) buf
| otherwise = ITvarsym pk_str
where
(C# f) = _HEAD_ pk_str
+ -- tl = _TAIL_ pk_str
mk_qvar_token m token =
+-- trace ("mk_qvar ") $
case mk_var_token token of
ITconid n -> ITqconid (m,n)
ITvarid n -> ITqvarid (m,n)
\end{code}
-----------------------------------------------------------------------------
-doDiscard rips along really fast, looking for a '#-}',
+doDiscard rips along really fast, looking for a '##-}',
indicating the end of the pragma we're skipping
\begin{code}
doDiscard inStr buf =
case currentChar# buf of
- '#'# | not inStr ->
+ '#'# | inStr ==# 0# ->
case lookAhead# buf 1# of { '#'# ->
case lookAhead# buf 2# of { '-'# ->
case lookAhead# buf 3# of { '}'# ->
_ -> doDiscard inStr (incLexeme buf) };
_ -> doDiscard inStr (incLexeme buf) };
_ -> doDiscard inStr (incLexeme buf) }
+
'"'# ->
let
odd_slashes buf flg i# =
case lookAhead# buf i# of
'\\'# -> odd_slashes buf (not flg) (i# -# 1#)
_ -> flg
+
+ not_inStr = if inStr ==# 0# then 1# else 0#
in
case lookAhead# buf (negateInt# 1#) of --backwards, actually
'\\'# -> -- escaping something..
- if odd_slashes buf True (negateInt# 2#) then
- -- odd number of slashes, " is escaped.
- doDiscard inStr (incLexeme buf)
- else
- -- even number of slashes, \ is escaped.
- doDiscard (not inStr) (incLexeme buf)
- _ -> case inStr of -- forced to avoid build-up
- True -> doDiscard False (incLexeme buf)
- False -> doDiscard True (incLexeme buf)
+ if odd_slashes buf True (negateInt# 2#)
+ then -- odd number of slashes, " is escaped.
+ doDiscard inStr (incLexeme buf)
+ else -- even number of slashes, \ is escaped.
+ doDiscard not_inStr (incLexeme buf)
+ _ -> doDiscard not_inStr (incLexeme buf)
+
+ '\''# | inStr ==# 0# ->
+ case lookAhead# buf 1# of { '"'# ->
+ case lookAhead# buf 2# of { '\''# ->
+ doDiscard inStr (setCurrentPos# buf 3#);
+ _ -> doDiscard inStr (incLexeme buf) };
+ _ -> doDiscard inStr (incLexeme buf) }
+
_ -> doDiscard inStr (incLexeme buf)
\end{code}
projects / ghc-hetmet.git / blobdiff