[project @ 1999-06-28 16:23:28 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index cdad859..118e58e 100644 (file)
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -28,7 +28,7 @@ module TcGenDeriv (
 
 import HsSyn           ( InPat(..), HsExpr(..), MonoBinds(..),
                          Match(..), GRHSs(..), Stmt(..), HsLit(..),
-                         HsBinds(..), StmtCtxt(..),
+                         HsBinds(..), StmtCtxt(..), HsType(..),
                          unguardedRHS, mkSimpleMatch
                        )
 import RdrHsSyn                ( mkOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
@@ -49,7 +49,7 @@ import PrimOp         ( PrimOp(..) )
 import PrelInfo                -- Lots of RdrNames
 import SrcLoc          ( mkGeneratedSrcLoc, SrcLoc )
 import TyCon           ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
-                         maybeTyConSingleCon
+                         maybeTyConSingleCon, tyConFamilySize
                        )
 import Type            ( isUnLiftedType, isUnboxedType, Type )
 import TysPrim         ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
@@ -59,6 +59,7 @@ import Util           ( mapAccumL, zipEqual, zipWithEqual,
                          zipWith3Equal, nOfThem )
 import Panic           ( panic, assertPanic )
 import Maybes          ( maybeToBool, assocMaybe )
+import Constants
 import List            ( partition, intersperse )
 \end{code}
 
@@ -305,7 +306,8 @@ JJQC-30-Nov-1997
 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
 
 gen_Ord_binds tycon
-  = defaulted `AndMonoBinds` compare
+  = compare    -- `AndMonoBinds` compare       
+               -- The default declaration in PrelBase handles this
   where
     tycon_loc = getSrcLoc tycon
     --------------------------------------------------------------------
@@ -386,6 +388,8 @@ gen_Ord_binds tycon
                                                                -- Tags are equal, no args => return EQ
     --------------------------------------------------------------------
 
+{- Not necessary: the default decls in PrelBase handle these 
+
 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
 
 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
@@ -401,6 +405,7 @@ max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
            compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
            compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
+-}
 \end{code}
 
 %************************************************************************
@@ -839,14 +844,14 @@ gen_Read_binds fixities tycon
                                 ])
              | lab_fields == 0 =  -- common case.
                  snd (mapAccumL mk_qual 
-                                c_Expr 
+                                d_Expr 
                                 (zipWithEqual "as_needed" 
                                               (\ con_field draw_from -> (mk_read_qual 10 con_field,
                                                                          draw_from))
                                                as_needed bs_needed))
               | otherwise =
                  snd $
-                 mapAccumL mk_qual c_Expr
+                 mapAccumL mk_qual d_Expr
                        (zipEqual "bs_needed"        
                           ((str_qual "{":
                             concat (
@@ -890,8 +895,9 @@ gen_Read_binds fixities tycon
             | not is_infix  = 9
             | otherwise     = getFixity fixities dc_nm
 
-          read_paren_arg  = -- parens depend on precedence...
-            HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))
+          read_paren_arg   -- parens depend on precedence...
+           | nullary_con  = false_Expr -- it's optional.
+           | otherwise    = HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))
 
 \end{code}
 
@@ -1063,10 +1069,17 @@ gen_tag_n_con_monobind
     -> RdrNameMonoBinds
 
 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
+  | lots_of_constructors
+  = mk_FunMonoBind (getSrcLoc tycon) rdr_name 
+       [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
+
+  | otherwise
   = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
+
   where
-    mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
+    lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
 
+    mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
     mk_stuff var
       = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
       where
@@ -1074,14 +1087,10 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
        var_RDR = qual_orig_name var
 
 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
-  = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon) ++ 
-                                                            [([WildPatIn], impossible_Expr)])
-  where
-    mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
-    mk_stuff var = ([lit_pat], HsVar var_RDR)
-      where
-       lit_pat = ConPatIn mkInt_RDR [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
-       var_RDR  = qual_orig_name var
+  = mk_FunMonoBind (getSrcLoc tycon) rdr_name 
+       [([ConPatIn mkInt_RDR [VarPatIn a_RDR]], 
+          ExprWithTySig (HsApp tagToEnum_Expr a_Expr) 
+                        (MonoTyVar (qual_orig_name tycon)))]
 
 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
   = mk_easy_FunMonoBind (getSrcLoc tycon) 
@@ -1351,6 +1360,8 @@ gtTag_Expr        = HsVar gtTag_RDR
 false_Expr     = HsVar false_RDR
 true_Expr      = HsVar true_RDR
 
+getTag_Expr    = HsVar getTag_RDR
+tagToEnum_Expr         = HsVar tagToEnumH_RDR
 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
 
 a_Pat          = VarPatIn a_RDR