projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Improve pretty-printing of Core
[ghc-hetmet.git]
/
compiler
/
parser
/
Lexer.x
diff --git
a/compiler/parser/Lexer.x
b/compiler/parser/Lexer.x
index
4c1b48e
..
bc11340
100644
(file)
--- a/
compiler/parser/Lexer.x
+++ b/
compiler/parser/Lexer.x
@@
-65,7
+65,7
@@
$decdigit = $ascdigit -- for now, should really be $digit (ToDo)
$digit = [$ascdigit $unidigit]
$special = [\(\)\,\;\[\]\`\{\}]
$digit = [$ascdigit $unidigit]
$special = [\(\)\,\;\[\]\`\{\}]
-$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]
+$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~ \xa1-\xbf \xd7 \xf7]
$unisymbol = \x04
$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\']
$unisymbol = \x04
$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\']
@@
-216,6
+216,11
@@
$white_no_nl+ ;
"{-#" $whitechar* (INCLUDE|include) { lex_string_prag ITinclude_prag }
}
"{-#" $whitechar* (INCLUDE|include) { lex_string_prag ITinclude_prag }
}
+<0,option_prags,glaexts> {
+ -- This is to catch things like {-# OPTIONS OPTIONS_HUGS ...
+ "{-#" $whitechar* $idchar+ { nested_comment }
+}
+
-- '0' state: ordinary lexemes
-- 'glaexts' state: glasgow extensions (postfix '#', etc.)
-- '0' state: ordinary lexemes
-- 'glaexts' state: glasgow extensions (postfix '#', etc.)
@@
-371,6
+376,8
@@
data Token
| ITccallconv
| ITdotnet
| ITmdo
| ITccallconv
| ITdotnet
| ITmdo
+ | ITiso
+ | ITfamily
-- Pragmas
| ITinline_prag Bool -- True <=> INLINE, False <=> NOINLINE
-- Pragmas
| ITinline_prag Bool -- True <=> INLINE, False <=> NOINLINE
@@
-494,6
+501,8
@@
isSpecial ITunsafe = True
isSpecial ITccallconv = True
isSpecial ITstdcallconv = True
isSpecial ITmdo = True
isSpecial ITccallconv = True
isSpecial ITstdcallconv = True
isSpecial ITmdo = True
+isSpecial ITiso = True
+isSpecial ITfamily = True
isSpecial _ = False
-- the bitmap provided as the third component indicates whether the
isSpecial _ = False
-- the bitmap provided as the third component indicates whether the
@@
-534,6
+543,7
@@
reservedWordsFM = listToUFM $
( "forall", ITforall, bit tvBit),
( "mdo", ITmdo, bit glaExtsBit),
( "forall", ITforall, bit tvBit),
( "mdo", ITmdo, bit glaExtsBit),
+ ( "family", ITfamily, bit idxTysBit),
( "foreign", ITforeign, bit ffiBit),
( "export", ITexport, bit ffiBit),
( "foreign", ITforeign, bit ffiBit),
( "export", ITexport, bit ffiBit),
@@
-567,8
+577,9
@@
reservedSymsFM = listToUFM $
,("-", ITminus, 0)
,("!", ITbang, 0)
,("-", ITminus, 0)
,("!", ITbang, 0)
- ,("*", ITstar, bit glaExtsBit) -- For data T (a::*) = MkT
- ,(".", ITdot, bit tvBit) -- For 'forall a . t'
+ ,("*", ITstar, bit glaExtsBit .|.
+ bit idxTysBit) -- For data T (a::*) = MkT
+ ,(".", ITdot, bit tvBit) -- For 'forall a . t'
,("-<", ITlarrowtail, bit arrowsBit)
,(">-", ITrarrowtail, bit arrowsBit)
,("-<", ITlarrowtail, bit arrowsBit)
,(">-", ITrarrowtail, bit arrowsBit)
@@
-583,6
+594,9
@@
reservedSymsFM = listToUFM $
,("→", ITrarrow, bit glaExtsBit)
,("←", ITlarrow, bit glaExtsBit)
,("⋯", ITdotdot, bit glaExtsBit)
,("→", ITrarrow, bit glaExtsBit)
,("←", ITlarrow, bit glaExtsBit)
,("⋯", ITdotdot, bit glaExtsBit)
+ -- ToDo: ideally, → and ∷ should be "specials", so that they cannot
+ -- form part of a large operator. This would let us have a better
+ -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe).
#endif
]
#endif
]
@@
-1210,6
+1224,7
@@
alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
alexGetChar (AI loc ofs s)
| atEnd s = Nothing
| otherwise = adj_c `seq` loc' `seq` ofs' `seq` s' `seq`
alexGetChar (AI loc ofs s)
| atEnd s = Nothing
| otherwise = adj_c `seq` loc' `seq` ofs' `seq` s' `seq`
+ --trace (show (ord c)) $
Just (adj_c, (AI loc' ofs' s'))
where (c,s') = nextChar s
loc' = advanceSrcLoc loc c
Just (adj_c, (AI loc' ofs' s'))
where (c,s') = nextChar s
loc' = advanceSrcLoc loc c
@@
-1259,6
+1274,7
@@
alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)
alexGetChar' (AI loc ofs s)
| atEnd s = Nothing
| otherwise = c `seq` loc' `seq` ofs' `seq` s' `seq`
alexGetChar' (AI loc ofs s)
| atEnd s = Nothing
| otherwise = c `seq` loc' `seq` ofs' `seq` s' `seq`
+ --trace (show (ord c)) $
Just (c, (AI loc' ofs' s'))
where (c,s') = nextChar s
loc' = advanceSrcLoc loc c
Just (c, (AI loc' ofs' s'))
where (c,s') = nextChar s
loc' = advanceSrcLoc loc c
@@
-1298,6
+1314,7
@@
ipBit = 6
tvBit = 7 -- Scoped type variables enables 'forall' keyword
bangPatBit = 8 -- Tells the parser to understand bang-patterns
-- (doesn't affect the lexer)
tvBit = 7 -- Scoped type variables enables 'forall' keyword
bangPatBit = 8 -- Tells the parser to understand bang-patterns
-- (doesn't affect the lexer)
+idxTysBit = 9 -- indexed type families: 'family' keyword and kind sigs
glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
glaExtsEnabled flags = testBit flags glaExtsBit
glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
glaExtsEnabled flags = testBit flags glaExtsBit
@@
-1308,6
+1325,7
@@
thEnabled flags = testBit flags thBit
ipEnabled flags = testBit flags ipBit
tvEnabled flags = testBit flags tvBit
bangPatEnabled flags = testBit flags bangPatBit
ipEnabled flags = testBit flags ipBit
tvEnabled flags = testBit flags tvBit
bangPatEnabled flags = testBit flags bangPatBit
+idxTysEnabled flags = testBit flags idxTysBit
-- PState for parsing options pragmas
--
-- PState for parsing options pragmas
--
@@
-1349,6
+1367,7
@@
mkPState buf loc flags =
.|. ipBit `setBitIf` dopt Opt_ImplicitParams flags
.|. tvBit `setBitIf` dopt Opt_ScopedTypeVariables flags
.|. bangPatBit `setBitIf` dopt Opt_BangPatterns flags
.|. ipBit `setBitIf` dopt Opt_ImplicitParams flags
.|. tvBit `setBitIf` dopt Opt_ScopedTypeVariables flags
.|. bangPatBit `setBitIf` dopt Opt_BangPatterns flags
+ .|. idxTysBit `setBitIf` dopt Opt_IndexedTypes flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
@@
-1443,15
+1462,13
@@
lexToken = do
span `seq` setLastToken span bytes
t span buf bytes
span `seq` setLastToken span bytes
t span buf bytes
--- ToDo: Alex reports the buffer at the start of the erroneous lexeme,
--- but it would be more informative to report the location where the
--- error was actually discovered, especially if this is a decoding
--- error.
-reportLexError loc1 loc2 buf str =
+reportLexError loc1 loc2 buf str
+ | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
+ | otherwise =
let
c = fst (nextChar buf)
in
if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#
let
c = fst (nextChar buf)
in
if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#
- then failLocMsgP loc2 loc2 "UTF-8 decoding error"
+ then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
}
else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
}