| ITdeprecated_prag
| ITline_prag
| ITscc_prag
+ | ITcore_prag -- hdaume: core annotations
| ITclose_prag
| ITdotdot -- reserved symbols
| 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
( "RULES", ITrules_prag ),
( "RULEZ", ITrules_prag ), -- american spelling :-)
( "SCC", ITscc_prag ),
+ ( "CORE", ITcore_prag ), -- hdaume: core annotation
( "DEPRECATED", ITdeprecated_prag )
]
ghcExtensionKeywordsFM = listToUFM $
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),
+
+ ( "rec", ITrec, bit glaExtsBit .|. bit arrowsBit),
+
( "foreign", ITforeign, bit ffiBit),
( "export", ITexport, bit ffiBit),
( "label", ITlabel, bit ffiBit),
( "safe", ITsafe, bit ffiBit),
( "threadsafe", ITthreadsafe, bit ffiBit),
( "unsafe", ITunsafe, bit ffiBit),
- ( "with", ITwith, bit withBit),
- ( "mdo", ITmdo, bit glaExtsBit),
( "stdcall", ITstdcallconv, bit ffiBit),
( "ccall", ITccallconv, bit ffiBit),
( "dotnet", ITdotnet, bit ffiBit),
+
+ ( "with", ITwith, bit withBit),
+
+ ( "proc", ITproc, bit arrowsBit),
+
+ -- On death row
("_ccall_", ITccall (False, False, PlayRisky),
bit glaExtsBit),
("_ccall_GC_", ITccall (False, False, PlaySafe False),
]
haskellKeySymsFM = listToUFM $
- map (\ (x,y) -> (mkFastString x,y))
- [ ("..", ITdotdot)
- ,(":", ITcolon) -- (:) is a reserved op,
+ map (\ (x,y,z) -> (mkFastString x,(y,z)))
+ [ ("..", ITdotdot, Nothing)
+ ,(":", ITcolon, Nothing) -- (:) is a reserved op,
-- meaning only list cons
- ,("::", ITdcolon)
- ,("=", ITequal)
- ,("\\", ITlam)
- ,("|", ITvbar)
- ,("<-", ITlarrow)
- ,("->", ITrarrow)
- ,("@", ITat)
- ,("~", ITtilde)
- ,("=>", ITdarrow)
- ,("-", ITminus)
- ,("!", ITbang)
- ,("*", ITstar)
- ,(".", ITdot) -- sadly, for 'forall a . t'
+ ,("::", 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}
case currentChar# buf of
-- special symbols ----------------------------------------------------
- '('# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '#'#
+ '('# | 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 (incCurrentPos buf)
'}'# | glaExtsEnabled exts -> cont ITccurlybar
(addToCurrentPos buf 2#)
-- MetaHaskell extension
- ']'# | glaExtsEnabled exts -> cont ITcloseQuote (addToCurrentPos buf 2#)
- other -> lex_sym cont (incCurrentPos buf)
+ ']'# | 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
(addToCurrentPos buf 2#)
- _ -> lex_sym cont (incCurrentPos buf)
+ _ -> lex_sym cont exts (incCurrentPos buf)
'#'# -> case lookAhead# buf 1# of
-> cont ITcubxparen (addToCurrentPos buf 2#)
'-'# -> case lookAhead# buf 2# of
'}'# -> cont ITclose_prag (addToCurrentPos buf 3#)
- _ -> lex_sym cont (incCurrentPos buf)
- _ -> lex_sym cont (incCurrentPos buf)
+ _ -> lex_sym cont exts (incCurrentPos buf)
+ _ -> lex_sym cont exts (incCurrentPos buf)
'`'# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '`'#
-> lex_cstring cont (addToCurrentPos buf 2#)
((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_lower c -> lex_id cont exts buf
| otherwise -> lexError "illegal character" buf
= case currentChar# buf of
'"'#{-"-} ->
let buf' = incCurrentPos buf
- s' = mkFastString (map chr (reverse s))
in case currentChar# buf' of
- '#'# | glaExtsEnabled exts -> if all (<= 0xFF) s
- then cont (ITprimstring s') (incCurrentPos 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#` '&'#
-- files is not that common. (ToDo)
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 = incCurrentPos buf2 in
- 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
-
- v = readRational__ (lexemeToString l)
-
- in case currentChar# l of -- glasgow exts only
- '#'# | glaExtsEnabled exts -> let l' = incCurrentPos l in
- case currentChar# l' of
- '#'# -> cont (ITprimdouble v) (incCurrentPos 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) (incCurrentPos buf)
}}}
-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'
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#)
glasgowExtsEF :: Bool,
ffiEF :: Bool,
withEF :: Bool,
- parrEF :: Bool
+ parrEF :: Bool,
+ arrowsEF :: Bool
}
-- create a parse state
|| glasgowExtsEF exts)
.|. withBit `setBitIf` withEF exts
.|. parrBit `setBitIf` parrEF exts
+ .|. arrowsBit `setBitIf` arrowsEF exts
--
setBitIf :: Int -> Bool -> Int32
b `setBitIf` cond | cond = bit b
projects / ghc-hetmet.git / blobdiff