[project @ 2002-06-05 14:08:23 by simonpj]

------------------------------------------------
	Fix the (new) lexer, and make the derived read
	and show code work according to the new H98 report
	------------------------------------------------


The new lexer, based on Koen's cunning parser (Text.ParserCombinators.ReadP)
wasn't quite right.  It's all very cool now.

In particular:

* The H98 "lex" function should return the exact string parsed, and it
now does, aided by the new combinator ReadP.gather.

* As a result the Text.Read.Lex Lexeme type is much simpler than before
    data Lexeme
      = Char   Char	-- Quotes removed,
      | String String	-- 	escapes interpreted
      | Punc   String 	-- Punctuation, eg "(", "::"
      | Ident  String	-- Haskell identifiers, e.g. foo, baz
      | Symbol String	-- Haskell symbols, e.g. >>, %
      | Int Integer
      | Rat Rational
      | EOF
     deriving (Eq,Show)

* Multi-character punctuation, like "::" was getting lexed as a Symbol,
but it should be a Punc.

* Parsing numbers wasn't quite right.  "1..n" got it confused because it
got committed to a decimal point and then found a second '.'.


* The new H98 spec for Show is there, which ignores associativity.

2 files changed, 75 insertions, 110 deletions

diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs
index 8dc8fb908a..dafee0d356 100644
--- a/ghc/compiler/prelude/PrelNames.lhs
+++ b/ghc/compiler/prelude/PrelNames.lhs
@@ -637,7 +637,7 @@ prec_RDR	   = varQual_RDR  rEAD_PREC_Name FSLIT("prec")
 -- Module Lex
 symbol_RDR	   = dataQual_RDR  lEX_Name FSLIT("Symbol")
 ident_RDR	   = dataQual_RDR  lEX_Name FSLIT("Ident")
-single_RDR	   = dataQual_RDR  lEX_Name FSLIT("Single")
+punc_RDR	   = dataQual_RDR  lEX_Name FSLIT("Punc")
 
 times_RDR	   = varQual_RDR  pREL_NUM_Name FSLIT("*")
 plus_RDR	   = varQual_RDR  pREL_NUM_Name FSLIT("+")
diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index 0f7400341f..50adfd6d8d 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -62,7 +62,7 @@ import Util		( mapAccumL, zipEqual, zipWithEqual, isSingleton,
 			  zipWith3Equal, nOfThem )
 import Panic		( panic, assertPanic )
 import Maybes		( maybeToBool )
-import Char		( ord )
+import Char		( ord, isAlpha )
 import Constants
 import List		( partition, intersperse )
 import FastString
@@ -759,11 +759,11 @@ instance Read T where
       +++
       prec appPrec (
 	do Ident "T1" <- Lex.lex
-	   Single '{' <- Lex.lex
+	   Punc '{' <- Lex.lex
 	   Ident "f1" <- Lex.lex
-	   Single '=' <- Lex.lex
+	   Punc '=' <- Lex.lex
 	   x	      <- ReadP.reset Read.readPrec
-	   Single '}' <- Lex.lex
+	   Punc '}' <- Lex.lex
 	   return (T1 { f1 = x }))
       +++
       prec appPrec (
@@ -802,7 +802,7 @@ gen_Read_binds get_fixity tycon
     read_nullary_cons 
       = case nullary_cons of
     	    []    -> []
-    	    [con] -> [HsDo DoExpr [BindStmt (ident_pat (data_con_str con)) lex loc,
+    	    [con] -> [HsDo DoExpr [bindLex (ident_pat (data_con_str con)),
     		      result_stmt con []] loc]
             _     -> [HsApp (HsVar choose_RDR) 
     		   	    (ExplicitList placeHolderType (map mk_pair nullary_cons))]
@@ -819,21 +819,21 @@ gen_Read_binds get_fixity tycon
      	      | otherwise	  = prefix_stmts
      
        	prefix_stmts		-- T a b c
-       	  = [BindStmt (ident_pat (data_con_str data_con)) lex loc]
+       	  = [bindLex (ident_pat (data_con_str data_con))]
        	    ++ map read_arg as_needed
        	    ++ [result_stmt data_con as_needed]
      	 
        	infix_stmts 		-- a %% b
        	  = [read_arg a1, 
-   	     BindStmt (symbol_pat (data_con_str data_con)) lex loc,
+   	     bindLex (symbol_pat (data_con_str data_con)),
      	     read_arg a2,
      	     result_stmt data_con [a1,a2]]
      
        	lbl_stmts		-- T { f1 = a, f2 = b }
-       	  = [BindStmt (ident_pat (data_con_str data_con)) lex loc,
-       	     read_punc '{']
-       	    ++ concat (intersperse [read_punc ','] field_stmts)
-       	    ++ [read_punc '}', result_stmt data_con as_needed]
+       	  = [bindLex (ident_pat (data_con_str data_con)),
+       	     read_punc "{"]
+       	    ++ concat (intersperse [read_punc ","] field_stmts)
+       	    ++ [read_punc "}", result_stmt data_con as_needed]
      
        	field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
      
@@ -841,36 +841,46 @@ gen_Read_binds get_fixity tycon
        	nullary_con  = con_arity == 0
        	labels       = dataConFieldLabels data_con
        	lab_fields   = length labels
-       	dc_nm	= getName data_con
+       	dc_nm	     = getName data_con
        	is_infix     = isDataSymOcc (getOccName dc_nm)
        	as_needed    = take con_arity as_RDRs
        	(a1:a2:_)    = as_needed
-     
-       	prec | not is_infix  = appPrecedence
-             | otherwise     = getPrecedence get_fixity dc_nm
+       	prec 	     = getPrec is_infix get_fixity dc_nm
 
     ------------------------------------------------------------------------
     --		Helpers
     ------------------------------------------------------------------------
     mk_alt e1 e2     = genOpApp e1 alt_RDR e2
+    bindLex pat	     = BindStmt pat (HsVar lexP_RDR) loc
     result_stmt c as = ResultStmt (HsApp (HsVar returnM_RDR) (con_app c as)) loc
     con_app c as     = mkHsVarApps (qual_orig_name c) as
     
-    lex          = HsVar lexP_RDR
-    single_pat c = ConPatIn single_RDR [LitPatIn (mkHsChar c)]	  -- Single 'x'
+    punc_pat s   = ConPatIn punc_RDR [LitPatIn (mkHsString s)]	  -- Punc 'c'
     ident_pat s  = ConPatIn ident_RDR [LitPatIn s]		  -- Ident "foo"
     symbol_pat s = ConPatIn symbol_RDR [LitPatIn s]		  -- Symbol ">>"
     
-    lbl_str :: FieldLabel -> HsLit
-    lbl_str      lbl = mkHsString (occNameUserString (getOccName (fieldLabelName lbl)))
     data_con_str con = mkHsString (occNameUserString (getOccName con))
     
-    read_punc c = BindStmt (single_pat c) lex loc
+    read_punc c = bindLex (punc_pat c)
     read_arg a  = BindStmt (VarPatIn a) (mkHsVarApps step_RDR [readPrec_RDR]) loc
     
-    read_field lbl a = [BindStmt (ident_pat (lbl_str lbl)) lex loc,
-    		        read_punc '=',
+    read_field lbl a = read_lbl lbl ++
+    		       [read_punc "=",
     		        BindStmt (VarPatIn a) (mkHsVarApps reset_RDR [readPrec_RDR]) loc]
+
+	-- When reading field labels we might encounter
+	-- 	a = 3
+	-- or	(#) = 4
+	-- Note the parens!
+    read_lbl lbl | isAlpha (head lbl_str) 
+		 = [bindLex (ident_pat lbl_lit)]
+		 | otherwise
+		 = [read_punc "(", 
+		    bindLex (symbol_pat lbl_lit),
+		    read_punc ")"]
+		 where	
+		   lbl_str = occNameUserString (getOccName (fieldLabelName lbl)) 
+		   lbl_lit = mkHsString lbl_str
 \end{code}
 
 
@@ -896,114 +906,69 @@ gen_Show_binds get_fixity tycon
 	pats_etc data_con
 	  | nullary_con =  -- skip the showParen junk...
 	     ASSERT(null bs_needed)
-	     ([wildPat, con_pat], show_con)
+	     ([wildPat, con_pat], mk_showString_app con_str)
 	  | otherwise   =
 	     ([a_Pat, con_pat],
-		  showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt paren_prec_limit))))
+		  showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt con_prec))))
 				 (HsPar (nested_compose_Expr show_thingies)))
 	    where
-	     data_con_RDR = qual_orig_name data_con
-	     con_arity    = dataConSourceArity data_con
-	     bs_needed    = take con_arity bs_RDRs
-	     con_pat      = ConPatIn data_con_RDR (map VarPatIn bs_needed)
-	     nullary_con  = con_arity == 0
-             labels       = dataConFieldLabels data_con
-	     lab_fields   = length labels
+	     data_con_RDR  = qual_orig_name data_con
+	     con_arity     = dataConSourceArity data_con
+	     bs_needed     = take con_arity bs_RDRs
+	     con_pat       = ConPatIn data_con_RDR (map VarPatIn bs_needed)
+	     nullary_con   = con_arity == 0
+             labels        = dataConFieldLabels data_con
+	     lab_fields    = length labels
+	     record_syntax = lab_fields > 0
 
 	     dc_nm	    = getName data_con
 	     dc_occ_nm	    = getOccName data_con
-             dc_occ_nm_str  = occNameUserString dc_occ_nm
-
-	     is_infix     = isDataSymOcc dc_occ_nm
+             con_str        = occNameUserString dc_occ_nm
 
-
-	     show_con
-	       | 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       = "{"
-		 
-
-	     show_all con fs@(x:xs)
-		| is_infix  = x:con:xs
-		| otherwise = 
-		  let
-                    ccurly_maybe 
-                      | lab_fields > 0  = [mk_showString_app "}"]
-                      | otherwise       = []
-		  in
-		  con:fs ++ ccurly_maybe
-
-	     show_thingies = show_all show_con real_show_thingies_with_labs
+	     show_thingies 
+		| is_infix     	= [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
+		| record_syntax = mk_showString_app (con_str ++ " {") : 
+				  show_record_args ++ [mk_showString_app "}"]
+		| otherwise	= mk_showString_app (con_str ++ " ") : show_prefix_args
                 
 	     show_label l = mk_showString_app (the_name ++ "=")
 		 where
 		   occ_nm   = getOccName (fieldLabelName l)
-		    -- legal, but rare.
-		   is_op    = isSymOcc occ_nm
+		   nm       = occNameUserString occ_nm
+
+		   is_op    = isSymOcc occ_nm	    -- Legal, but rare.
 		   the_name 
 		     | is_op     = '(':nm ++ ")"
 		     | otherwise = nm
 
-		   nm       = occNameUserString occ_nm
-		
-
-             mk_showString_app str = HsApp (HsVar showString_RDR)
-					   (HsLit (mkHsString str))
-
-             prec_cons = getLRPrecs is_infix get_fixity dc_nm
-
-             real_show_thingies
-		| is_infix  = 
-		     [ mkHsApps showsPrec_RDR [HsLit (HsInt p), HsVar b]
-		     | (p,b) <- zip prec_cons bs_needed ]
-		| otherwise =
-		     [ mkHsApps showsPrec_RDR [mkHsIntLit 10, HsVar b]
-		     | b <- bs_needed ]
-
-             real_show_thingies_with_labs
-		| lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
-		| otherwise       = --Assumption: no of fields == no of labelled fields 
-				     --            (and in same order)
-		    concat $
-		    intersperse ([mk_showString_app ","]) $ -- Using SLIT()s containing ,s spells trouble.
-		    zipWithEqual "gen_Show_binds"
-				 (\ a b -> [a,b])
-				 (map show_label labels) 
-				 real_show_thingies
+             show_args = [ mkHsApps showsPrec_RDR [HsLit (HsInt arg_prec), HsVar b]
+			 | b <- bs_needed ]
+	     (show_arg1:show_arg2:_) = show_args
+	     show_prefix_args = intersperse (HsVar showSpace_RDR) show_args
+
+
+		--  Assumption for record syntax: no of fields == no of labelled fields 
+		--            (and in same order)
+	     show_record_args = concat $
+				intersperse [mk_showString_app ", "] $
+				[ [show_label lbl, arg] 
+				| (lbl,arg) <- zipEqual "gen_Show_binds" 
+							labels show_args ]
 			       
-	      {-
-	        c.f. Figure 16 and 17 in Haskell 1.1 report
-	      -}  
-	     paren_prec_limit
-		| not is_infix = appPrecedence + 1
-		| otherwise    = getPrecedence get_fixity dc_nm + 1
+		-- Fixity stuff
+	     is_infix = isDataSymOcc dc_occ_nm
+             con_prec = 1 + getPrec is_infix get_fixity dc_nm
+	     arg_prec | record_syntax = 0	-- Record fields don't need parens
+		      | otherwise     = con_prec	
 
+mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (mkHsString str))
 \end{code}
 
 \begin{code}
-getLRPrecs :: Bool -> FixityEnv -> Name -> [Integer]
-getLRPrecs is_infix get_fixity nm = [lp, rp]
-    where
-     {-
-	Figuring out the fixities of the arguments to a constructor,
-	cf. Figures 16-18 in Haskell 1.1 report.
-     -}
-     (con_left_assoc, con_right_assoc) = isLRAssoc get_fixity nm
-     paren_con_prec = getPrecedence get_fixity nm
-
-     lp
-      | not is_infix   = appPrecedence + 1
-      | con_left_assoc = paren_con_prec
-      | otherwise      = paren_con_prec + 1
-		  
-     rp
-      | not is_infix    = appPrecedence + 1
-      | con_right_assoc = paren_con_prec
-      | otherwise       = paren_con_prec + 1
+getPrec :: Bool -> FixityEnv -> Name -> Integer
+getPrec is_infix get_fixity nm 
+  | not is_infix   = appPrecedence
+  | otherwise      = getPrecedence get_fixity nm
 		  
 appPrecedence :: Integer
 appPrecedence = fromIntegral maxPrecedence