Fix Trac #5041: parse the trailing '#'

[ghc-hetmet.git] / compiler / typecheck / TcGenDeriv.lhs

diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 2c04cf4..efacac2 100644 (file)
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -893,15 +893,15 @@ gen_Read_binds get_fixity loc tycon
     read_nullary_cons 
       = case nullary_cons of
            []    -> []
-           [con] -> [nlHsDo DoExpr [bindLex (match_con con)] (result_expr con [])]
+           [con] -> [nlHsDo DoExpr (match_con con) (result_expr con [])]
             _     -> [nlHsApp (nlHsVar choose_RDR) 
                              (nlList (map mk_pair nullary_cons))]
         -- NB For operators the parens around (:=:) are matched by the
        -- enclosing "parens" call, so here we must match the naked
        -- data_con_str con
 
-    match_con con | isSym con_str = symbol_pat con_str
-                  | otherwise     = ident_pat  con_str
+    match_con con | isSym con_str = [symbol_pat con_str]
+                  | otherwise     = ident_h_pat  con_str
                   where
                     con_str = data_con_str con
        -- For nullary constructors we must match Ident s for normal constrs
@@ -925,12 +925,12 @@ gen_Read_binds get_fixity loc tycon
        prefix_parser = mk_parser prefix_prec prefix_stmts body
 
        read_prefix_con
-           | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]
-           | otherwise     = [bindLex (ident_pat con_str)]
+           | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
+           | otherwise     = ident_h_pat con_str
         
        read_infix_con
-           | isSym con_str = [bindLex (symbol_pat con_str)]
-           | otherwise     = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]
+           | isSym con_str = [symbol_pat con_str]
+           | otherwise     = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
 
                prefix_stmts            -- T a b c
                  = read_prefix_con ++ read_args
@@ -972,8 +972,15 @@ gen_Read_binds get_fixity loc tycon
     result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as)                -- return (con as)
     
     punc_pat s   = nlConPat punc_RDR   [nlLitPat (mkHsString s)]  -- Punc 'c'
-    ident_pat s  = nlConPat ident_RDR  [nlLitPat (mkHsString s)]  -- Ident "foo"
-    symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)]  -- Symbol ">>"
+
+    -- For constructors and field labels ending in '#', we hackily
+    -- let the lexer generate two tokens, and look for both in sequence
+    -- Thus [Ident "I"; Symbol "#"].  See Trac #5041
+    ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
+                  | otherwise                    = [ ident_pat s ]
+                                  
+    ident_pat  s = bindLex $ nlConPat ident_RDR  [nlLitPat (mkHsString s)]  -- Ident "foo" <- lexP
+    symbol_pat s = bindLex $ nlConPat symbol_RDR [nlLitPat (mkHsString s)]  -- Symbol ">>" <- lexP
     
     data_con_str con = occNameString (getOccName con)
     
@@ -991,11 +998,9 @@ gen_Read_binds get_fixity loc tycon
        -- or   (#) = 4
        -- Note the parens!
     read_lbl lbl | isSym lbl_str 
-                = [read_punc "(", 
-                   bindLex (symbol_pat lbl_str),
-                   read_punc ")"]
+                = [read_punc "(", symbol_pat lbl_str, read_punc ")"]
                 | otherwise
-                = [bindLex (ident_pat lbl_str)]
+                = ident_h_pat lbl_str
                 where  
                   lbl_str = occNameString (getOccName lbl) 
 \end{code}