New syntax for stand-alone deriving. Implemented fully.

[ghc-hetmet.git] / compiler / parser / Lexer.x

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 1ede5f6..15745d5 100644 (file)
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -27,7 +27,7 @@ module Lexer (
    failLocMsgP, failSpanMsgP, srcParseFail,
    popContext, pushCurrentContext, setLastToken, setSrcLoc,
    getLexState, popLexState, pushLexState,
-   extension, bangPatEnabled
+   extension, glaExtsEnabled, bangPatEnabled
   ) where
 
 #include "HsVersions.h"
@@ -216,6 +216,11 @@ $white_no_nl+                              ;
   "{-#" $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.)
 
@@ -245,7 +250,6 @@ $white_no_nl+                               ;
 
 <0,glaexts> {
   \? @varid / { ifExtension ipEnabled }        { skip_one_varid ITdupipvarid }
-  \% @varid / { ifExtension ipEnabled } { skip_one_varid ITsplitipvarid }
 }
 
 <glaexts> {
@@ -341,6 +345,7 @@ data Token
   | ITderiving
   | ITdo
   | ITelse
+  | ITfor
   | IThiding
   | ITif
   | ITimport
@@ -371,6 +376,8 @@ data Token
   | ITccallconv
   | ITdotnet
   | ITmdo
+  | ITiso
+  | ITfamily
 
        -- Pragmas
   | ITinline_prag Bool         -- True <=> INLINE, False <=> NOINLINE
@@ -435,7 +442,6 @@ data Token
   | ITqconsym (FastString,FastString)
 
   | ITdupipvarid   FastString  -- GHC extension: implicit param: ?x
-  | ITsplitipvarid FastString  -- GHC extension: implicit param: %x
 
   | ITpragma StringBuffer
 
@@ -483,6 +489,7 @@ isSpecial :: Token -> Bool
 -- not as a keyword.
 isSpecial ITas         = True
 isSpecial IThiding     = True
+isSpecial ITfor        = True
 isSpecial ITqualified  = True
 isSpecial ITforall     = True
 isSpecial ITexport     = True
@@ -494,6 +501,8 @@ isSpecial ITunsafe          = 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
@@ -514,6 +523,7 @@ reservedWordsFM = listToUFM $
        ( "deriving",   ITderiving,     0 ), 
        ( "do",         ITdo,           0 ),       
        ( "else",       ITelse,         0 ),     
+       ( "for",        ITfor,          0 ),
        ( "hiding",     IThiding,       0 ),
        ( "if",         ITif,           0 ),       
        ( "import",     ITimport,       0 ),   
@@ -534,6 +544,7 @@ reservedWordsFM = listToUFM $
 
        ( "forall",     ITforall,        bit tvBit),
        ( "mdo",        ITmdo,           bit glaExtsBit),
+       ( "family",     ITfamily,        bit idxTysBit),
 
        ( "foreign",    ITforeign,       bit ffiBit),
        ( "export",     ITexport,        bit ffiBit),
@@ -567,8 +578,9 @@ reservedSymsFM = listToUFM $
        ,("-",  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)
@@ -583,6 +595,9 @@ reservedSymsFM = listToUFM $
        ,("→",   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
        ]
 
@@ -1210,6 +1225,7 @@ alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
 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
@@ -1259,6 +1275,7 @@ alexGetChar' :: AlexInput -> Maybe (Char,AlexInput)
 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
@@ -1298,6 +1315,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)
+idxTysBit  = 9 -- indexed type families: 'family' keyword and kind sigs
 
 glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool
 glaExtsEnabled flags = testBit flags glaExtsBit
@@ -1308,6 +1326,7 @@ thEnabled      flags = testBit flags thBit
 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
 --
@@ -1349,6 +1368,7 @@ mkPState buf loc 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
@@ -1443,15 +1463,13 @@ lexToken = do
        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#
-    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)
 }