From: sof <unknown>
Date: Mon, 5 Jul 1999 14:47:06 +0000 (+0000)
Subject: [project @ 1999-07-05 14:47:06 by sof]
X-Git-Tag: Approximately_9120_patches~6040
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=8be6668261980a9b71d5e06c8bbd2e3e4b205efb;p=ghc-hetmet.git

[project @ 1999-07-05 14:47:06 by sof]
* If a field label is a 'varsym', wrap parens around it when
  Show'ing and Read'ing it back in.

* If there's no fixity decl for a 'consym', the default is
  for it to be left-assoc.
---

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index fe86a76..3385fbd 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -42,7 +42,8 @@ import DataCon		( isNullaryDataCon, dataConTag,
 			  dataConFieldLabels )
 import Name		( getOccString, getOccName, getSrcLoc, occNameString, 
 			  occNameUserString, nameRdrName, varName,
-			  OccName, Name, NamedThing(..), NameSpace
+			  OccName, Name, NamedThing(..), NameSpace,
+			  isDataSymOcc, isSymOcc
 			)
 
 import PrimOp		( PrimOp(..) )
@@ -61,6 +62,7 @@ import Panic		( panic, assertPanic )
 import Maybes		( maybeToBool, assocMaybe )
 import Constants
 import List		( partition, intersperse )
+import Char		( isAlpha )
 \end{code}
 
 %************************************************************************
@@ -799,9 +801,9 @@ gen_Read_binds fixities tycon
 	   labels       = dataConFieldLabels data_con
 	   lab_fields   = length labels
 	   dc_nm	= getName data_con
-	   is_infix     = isInfixOccName data_con_str
+	   is_infix     = isDataSymOcc (getOccName dc_nm)
 
-  	   as_needed   = take con_arity as_RDRs
+  	   as_needed    = take con_arity as_RDRs
 	   bs_needed   
 	     | is_infix        = take (1 + con_arity) bs_RDRs
 	     | lab_fields == 0 = take con_arity bs_RDRs
@@ -830,10 +832,22 @@ gen_Read_binds fixities tycon
 		  (HsApp (HsVar lex_RDR) draw_from)
 		  tycon_loc
   
-	   read_label f = [str_qual nm, str_qual "="] 
+	   str_qual_paren str res draw_from =
+               BindStmt
+		  (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] True)
+		  (HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from)
+		  tycon_loc
+  
+	   read_label f = [rd_lab, str_qual "="] 
 			    -- There might be spaces between the label and '='
 		where
-		  nm = occNameUserString (getOccName (fieldLabelName f))
+		  rd_lab
+		   | is_op	= str_qual_paren nm
+		   | otherwise  = str_qual nm
+
+		  occ_nm  = getOccName (fieldLabelName f)
+		  is_op   = isSymOcc occ_nm
+		  nm      = occNameUserString occ_nm
 
 	   field_quals
 	      | is_infix  =
@@ -936,22 +950,22 @@ gen_Show_binds fixs_assoc tycon
              labels       = dataConFieldLabels data_con
 	     lab_fields   = length labels
 
-             dc_occ_nm    = occNameUserString (getOccName data_con)
-	     dc_nm	  = getName data_con
+	     dc_nm	    = getName data_con
+	     dc_occ_nm	    = getOccName data_con
+             dc_occ_nm_str  = occNameUserString dc_occ_nm
 
-	     is_infix     = isInfixOccName dc_occ_nm
+	     is_infix     = isDataSymOcc dc_occ_nm
 
 
 	     show_con
-	       | is_infix  = mk_showString_app (' ':dc_occ_nm)
-	       | otherwise =
-	         let 
+	       | is_infix  = mk_showString_app (' ':dc_occ_nm_str)
+	       | otherwise = mk_showString_app (dc_occ_nm_str ++ space_ocurly_maybe)
+		 where
 	          space_ocurly_maybe
                     | nullary_con     = ""
 		    | lab_fields == 0 = " "
 		    | otherwise       = "{"
-		 in
-		 mk_showString_app (dc_occ_nm ++ space_ocurly_maybe)
+		 
 
 	     show_all con fs@(x:xs)
 		| is_infix  = x:con:xs
@@ -965,9 +979,16 @@ gen_Show_binds fixs_assoc tycon
 
 	     show_thingies = show_all show_con real_show_thingies_with_labs
                 
-	     show_label l  = mk_showString_app (nm ++ "=")
+	     show_label l = mk_showString_app (the_name ++ "=")
 		 where
-		   nm = occNameUserString (getOccName (fieldLabelName l))
+		   occ_nm   = getOccName (fieldLabelName l)
+		    -- legal, but rare.
+		   is_op    = isSymOcc occ_nm
+		   the_name 
+		     | is_op     = '(':nm ++ ")"
+		     | otherwise = nm
+
+		   nm       = occNameUserString occ_nm
 		
 
              mk_showString_app str = HsApp (HsVar showString_RDR)
@@ -1029,13 +1050,8 @@ isLRAssoc fixs_assoc nm =
      case assocMaybe fixs_assoc nm of
        Just (Fixity _ InfixL) -> (True, False)
        Just (Fixity _ InfixR) -> (False, True)
-       _		      -> (False, False)
-
-isInfixOccName :: String -> Bool
-isInfixOccName str = 
-   case str of
-     (':':_) -> True
-     _       -> False
+       Just (Fixity _ _)      -> (False, False)
+       _		      -> (True, False)
 
 \end{code}