X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=959f0c890c7ac639fb596743ead82b34b88f7a3b;hb=aecb51e1bbecef1872f9a3bb11856f39fa291f15;hp=46deaa0e1e43b7a4d7acf82dd0e440421a61b9da;hpb=f3c7ab8dbd5a46ef5a7aeeb398a6d4bc1482e606;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 46deaa0..959f0c8 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -889,14 +889,23 @@ gen_Read_binds get_fixity loc tycon
     read_nullary_cons 
       = case nullary_cons of
     	    []    -> []
-    	    [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
-				    (result_expr con [])]
+    	    [con] -> [nlHsDo DoExpr [bindLex (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
+                  where
+                    con_str = data_con_str con
+	-- For nullary constructors we must match Ident s for normal constrs
+	-- and   Symbol s   for operators
+
     mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)), 
 			          result_expr con []]
-    
+
     read_non_nullary_con data_con
       | is_infix  = mk_parser infix_prec  infix_stmts  body
       | is_record = mk_parser record_prec record_stmts body
@@ -1032,7 +1041,7 @@ gen_Show_binds get_fixity loc tycon
 	pats_etc data_con
 	  | nullary_con =  -- skip the showParen junk...
 	     ASSERT(null bs_needed)
-	     ([nlWildPat, con_pat], mk_showString_app con_str)
+	     ([nlWildPat, con_pat], mk_showString_app op_con_str)
 	  | otherwise   =
 	     ([a_Pat, con_pat],
 		  showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
@@ -1370,12 +1379,18 @@ gen_Functor_binds loc tycon
   = (unitBag fmap_bind, [])
   where
     data_cons = tyConDataCons tycon
-
-    fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) (map fmap_eqn data_cons)
+    fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) eqns
+                                  
     fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
       where 
         parts = foldDataConArgs ft_fmap con
 
+	-- Catch-all eqn looks like   fmap _ _ = error "impossible"
+	-- It's needed if there no data cons at all 
+    eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat] 
+                                           (error_Expr "Void fmap")]
+         | otherwise      = map fmap_eqn data_cons
+
     ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
     -- Tricky higher order type; I can't say I fully understand this code :-(
     ft_fmap = FT { ft_triv = \x -> return x                    -- fmap f x = x
@@ -1536,7 +1551,10 @@ gen_Foldable_binds loc tycon
   where
     data_cons = tyConDataCons tycon
 
-    foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) (map foldr_eqn data_cons)
+    foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) eqns
+    eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat, nlWildPat] 
+                                           (error_Expr "Void foldr")]
+         | otherwise      = map foldr_eqn data_cons
     foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
       where 
         parts = foldDataConArgs ft_foldr con
@@ -1587,7 +1605,10 @@ gen_Traversable_binds loc tycon
   where
     data_cons = tyConDataCons tycon
 
-    traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) (map traverse_eqn data_cons)
+    traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) eqns
+    eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat] 
+                                           (error_Expr "Void traverse")]
+         | otherwise      = map traverse_eqn data_cons
     traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
       where 
         parts = foldDataConArgs ft_trav con
@@ -1825,8 +1846,8 @@ nested_compose_Expr (e:es)
 
 -- impossible_Expr is used in case RHSs that should never happen.
 -- We generate these to keep the desugarer from complaining that they *might* happen!
--- impossible_Expr :: LHsExpr RdrName
--- impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
+error_Expr :: String -> LHsExpr RdrName
+error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
 
 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
 -- method. It is currently only used by Enum.{succ,pred}