Fix typo

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

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index a0d1c85..40e091d 100644 (file)
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -54,7 +54,6 @@ import TysWiredIn     ( charDataCon, intDataCon, floatDataCon, doubleDataCon,
                          intDataCon_RDR, true_RDR, false_RDR )
 import Util            ( zipWithEqual, isSingleton,
                          zipWith3Equal, nOfThem, zipEqual )
-import Char            ( isAlpha )
 import Constants
 import List            ( partition, intersperse )
 import Outputable
@@ -298,8 +297,8 @@ gen_Ord_binds tycon
     tycon_loc = getSrcSpan tycon
     --------------------------------------------------------------------
 
-    compare = L tycon_loc (FunBind (L tycon_loc compare_RDR) False compare_matches placeHolderNames)
-    compare_matches = mkMatchGroup [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
+    compare = L tycon_loc (mkFunBind (L tycon_loc compare_RDR) compare_matches)
+    compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
     cmp_eq_binds    = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
 
     compare_rhs
@@ -756,9 +755,9 @@ gen_Read_binds get_fixity tycon
             _     -> [nlHsApp (nlHsVar choose_RDR) 
                            (nlList (map mk_pair nullary_cons))]
     
-    mk_pair con = nlTuple [nlHsLit (data_con_str con),
-                                nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))]
-                               Boxed
+    mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
+                                  nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))]
+                                  Boxed
     
     read_non_nullary_con data_con
       = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts body]
@@ -768,18 +767,21 @@ gen_Read_binds get_fixity tycon
              | otherwise         = prefix_stmts
      
        body = result_expr data_con as_needed
+       con_str = data_con_str data_con
        
                prefix_stmts            -- T a b c
-                 = [bindLex (ident_pat (data_con_str_w_parens data_con))]
+                 = [bindLex (ident_pat (wrapOpParens con_str))]
                    ++ read_args
         
-               infix_stmts             -- a %% b
-                 = [read_a1, 
-            bindLex (symbol_pat (data_con_str data_con)),
-            read_a2]
+               infix_stmts             -- a %% b, or  a `T` b 
+                 = [read_a1]
+           ++  (if isSym con_str
+                then [bindLex (symbol_pat con_str)]
+                else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
+           ++ [read_a2]
      
                lbl_stmts               -- T { f1 = a, f2 = b }
-                 = [bindLex (ident_pat (data_con_str_w_parens data_con)),
+                 = [bindLex (ident_pat (wrapOpParens con_str)),
                     read_punc "{"]
                    ++ concat (intersperse [read_punc ","] field_stmts)
                    ++ [read_punc "}"]
@@ -803,12 +805,11 @@ gen_Read_binds get_fixity tycon
     con_app c as     = nlHsVarApps (getRdrName c) as
     result_expr c as = nlHsApp (nlHsVar returnM_RDR) (con_app c as)
     
-    punc_pat s   = nlConPat punc_RDR  [nlLitPat (mkHsString s)]          -- Punc 'c'
-    ident_pat s  = nlConPat ident_RDR [nlLitPat s]               -- Ident "foo"
-    symbol_pat s = nlConPat symbol_RDR [nlLitPat s]              -- Symbol ">>"
+    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 ">>"
     
-    data_con_str          con = mkHsString (occNameUserString (getOccName con))
-    data_con_str_w_parens con = mkHsString (occNameUserString_with_parens (getOccName con))
+    data_con_str con = occNameString (getOccName con)
     
     read_punc c = bindLex (punc_pat c)
     read_arg a ty 
@@ -824,16 +825,14 @@ gen_Read_binds get_fixity tycon
        --      _a = 3
        -- or   (#) = 4
        -- Note the parens!
-    read_lbl lbl | is_id_start (head lbl_str) 
-                = [bindLex (ident_pat lbl_lit)]
-                | otherwise
+    read_lbl lbl | isSym lbl_str 
                 = [read_punc "(", 
-                   bindLex (symbol_pat lbl_lit),
+                   bindLex (symbol_pat lbl_str),
                    read_punc ")"]
+                | otherwise
+                = [bindLex (ident_pat lbl_str)]
                 where  
-                  lbl_str = occNameUserString (getOccName lbl) 
-                  lbl_lit = mkHsString lbl_str
-                  is_id_start c = isAlpha c || c == '_'
+                  lbl_str = occNameString (getOccName lbl) 
 \end{code}
 
 
@@ -900,11 +899,12 @@ gen_Show_binds get_fixity tycon
 
             dc_nm          = getName data_con
             dc_occ_nm      = getOccName data_con
-             con_str        = occNameUserString dc_occ_nm
-            op_con_str     = occNameUserString_with_parens dc_occ_nm
+             con_str        = occNameString dc_occ_nm
+            op_con_str     = wrapOpParens con_str
+            backquote_str  = wrapOpBackquotes con_str
 
             show_thingies 
-               | is_infix      = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
+               | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
                | record_syntax = mk_showString_app (op_con_str ++ " {") : 
                                  show_record_args ++ [mk_showString_app "}"]
                | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
@@ -916,7 +916,7 @@ gen_Show_binds get_fixity tycon
                        -- it seems tidier to have them both sides.
                 where
                   occ_nm   = getOccName l
-                  nm       = occNameUserString_with_parens occ_nm
+                  nm       = wrapOpParens (occNameString occ_nm)
 
              show_args                      = zipWith show_arg bs_needed arg_tys
             (show_arg1:show_arg2:_) = show_args
@@ -942,12 +942,17 @@ gen_Show_binds get_fixity tycon
             arg_prec | record_syntax = 0       -- Record fields don't need parens
                      | otherwise     = con_prec_plus_one
 
-occNameUserString_with_parens :: OccName -> String
-occNameUserString_with_parens occ
-  | isSymOcc occ = '(':nm ++ ")"
-  | otherwise    = nm
-  where
-   nm = occNameUserString occ
+wrapOpParens :: String -> String
+wrapOpParens s | isSym s   = '(' : s ++ ")"
+              | otherwise = s
+
+wrapOpBackquotes :: String -> String
+wrapOpBackquotes s | isSym s   = s
+                  | otherwise = '`' : s ++ "`"
+
+isSym :: String -> Bool
+isSym ""     = False
+isSym (c:cs) = startsVarSym c || startsConSym c
 
 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
 \end{code}
@@ -1123,7 +1128,7 @@ gen_Data_binds fix_env tycon
     constr_args dc =
         [ -- nlHsIntLit (toInteger (dataConTag dc)),           -- Tag
           nlHsVar data_type_name,                              -- DataType
-          nlHsLit (mkHsString (occNameUserString dc_occ)),     -- String name
+          nlHsLit (mkHsString (occNameString dc_occ)), -- String name
            nlList  labels,                                     -- Field labels
           nlHsVar fixity]                                      -- Fixity
        where
@@ -1453,7 +1458,7 @@ mk_tc_deriv_name tycon str
   = mkDerivedRdrName tc_name mk_occ
   where
     tc_name = tyConName tycon
-    mk_occ tc_occ = mkOccFS varName (mkFastString new_str)
+    mk_occ tc_occ = mkVarOccFS (mkFastString new_str)
                  where
                    new_str = str ++ occNameString tc_occ ++ "#"
 \end{code}