Big tidy-up of deriving code

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

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 6a25ae5..316f21f 100644 (file)
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -233,6 +233,8 @@ $white_no_nl+                               ;
   "{-#" $whitechar* (DEPRECATED|deprecated)
                                        { token ITdeprecated_prag }
   "{-#" $whitechar* (SCC|scc)          { token ITscc_prag }
+  "{-#" $whitechar* (GENERATED|generated)
+                                       { token ITgenerated_prag }
   "{-#" $whitechar* (CORE|core)                { token ITcore_prag }
   "{-#" $whitechar* (UNPACK|unpack)    { token ITunpack_prag }
 
@@ -387,9 +389,9 @@ data Token
   | ITdata
   | ITdefault
   | ITderiving
+  | ITderived
   | ITdo
   | ITelse
-  | ITfor
   | IThiding
   | ITif
   | ITimport
@@ -432,6 +434,7 @@ data Token
   | ITdeprecated_prag
   | ITline_prag
   | ITscc_prag
+  | ITgenerated_prag
   | ITcore_prag                 -- hdaume: core annotations
   | ITunpack_prag
   | ITclose_prag
@@ -541,7 +544,7 @@ isSpecial :: Token -> Bool
 -- not as a keyword.
 isSpecial ITas         = True
 isSpecial IThiding     = True
-isSpecial ITfor        = True
+isSpecial ITderived            = True
 isSpecial ITqualified  = True
 isSpecial ITforall     = True
 isSpecial ITexport     = True
@@ -573,9 +576,9 @@ reservedWordsFM = listToUFM $
        ( "data",       ITdata,         0 ),     
        ( "default",    ITdefault,      0 ),  
        ( "deriving",   ITderiving,     0 ), 
+       ( "derived",    ITderived,      0 ), 
        ( "do",         ITdo,           0 ),       
        ( "else",       ITelse,         0 ),     
-       ( "for",        ITfor,          0 ),
        ( "hiding",     IThiding,       0 ),
        ( "if",         ITif,           0 ),       
        ( "import",     ITimport,       0 ),   
@@ -690,24 +693,23 @@ pop _span _buf _len = do popLexState; lexToken
 pop_and :: Action -> Action
 pop_and act span buf len = do popLexState; act span buf len
 
-notFollowedBy char _ _ _ (AI _ _ buf) = atEnd buf || currentChar buf /= char
+{-# INLINE nextCharIs #-}
+nextCharIs buf p = not (atEnd buf) && p (currentChar buf)
+
+notFollowedBy char _ _ _ (AI _ _ buf) 
+  = nextCharIs buf (/=char)
 
 notFollowedBySymbol _ _ _ (AI _ _ buf)
-  = atEnd buf || currentChar buf `notElem` "!#$%&*+./<=>?@\\^|-~"
+  = nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~")
 
 isNormalComment bits _ _ (AI _ _ buf)
-  = (if haddockEnabled bits then False else (followedBySpaceDoc buf))
-    || notFollowedByDocOrPragma
+  | haddockEnabled bits = notFollowedByDocOrPragma
+  | otherwise           = nextCharIs buf (/='#')
   where 
-    notFollowedByDocOrPragma = not $ spaceAndP buf
-      (\buf' -> currentChar buf' `elem` "|^*$#")
-
-spaceAndP buf p = p buf || currentChar buf == ' ' && p buf'
-  where buf' = snd (nextChar buf)
-
-followedBySpaceDoc buf = spaceAndP buf followedByDoc
+    notFollowedByDocOrPragma 
+       = not $ spaceAndP buf (`nextCharIs` (`elem` "|^*$#"))
 
-followedByDoc buf = currentChar buf `elem` "|^*$"
+spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf))
 
 haddockDisabledAnd p bits _ _ (AI _ _ buf)
   = if haddockEnabled bits then False else (p buf)