[project @ 1997-07-31 00:05:10 by sof]

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

diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index 4587e18..d317f10 100644 (file)
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -30,25 +30,26 @@ module TcGenDeriv (
 IMP_Ubiq()
 IMPORT_1_3(List(partition))
 
-import HsSyn           ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
+import HsSyn           ( HsBinds(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
                          GRHS(..), HsExpr(..), HsLit(..), InPat(..), Stmt(..), DoOrListComp(..),
+                         SYN_IE(RecFlag), recursive,
                          ArithSeqInfo, Sig, HsType, FixityDecl, Fixity, Fake )
 import RdrHsSyn                ( RdrName(..), varQual, varUnqual, mkOpApp,
                          SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat)
                        )
--- import RnHsSyn              ( RenamedFixityDecl(..) )
-
-import Id              ( GenId, dataConNumFields, isNullaryDataCon, dataConTag,
+import BasicTypes      ( IfaceFlavour(..) )
+import Id              ( GenId, isNullaryDataCon, dataConTag,
                          dataConRawArgTys, fIRST_TAG,
-                         isDataCon, SYN_IE(DataCon), SYN_IE(ConTag) )
+                         isDataCon, SYN_IE(DataCon), SYN_IE(ConTag),
+                         SYN_IE(Id) )
 import Maybes          ( maybeToBool )
 import Name            ( getOccString, getOccName, getSrcLoc, occNameString, modAndOcc, OccName, Name )
 
 import PrimOp          ( PrimOp(..) )
 import PrelInfo                -- Lots of RdrNames
-import SrcLoc          ( mkGeneratedSrcLoc )
-import TyCon           ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
-import Type            ( eqTy, isPrimType )
+import SrcLoc          ( mkGeneratedSrcLoc, SrcLoc )
+import TyCon           ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
+import Type            ( eqTy, isPrimType, SYN_IE(Type) )
 import TysPrim         ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
                          floatPrimTy, doublePrimTy
                        )
@@ -140,8 +141,9 @@ gen_Eq_binds :: TyCon -> RdrNameMonoBinds
 gen_Eq_binds tycon
   = let
        tycon_loc = getSrcLoc tycon
-       (nullary_cons, nonnullary_cons)
-         = partition isNullaryDataCon (tyConDataCons tycon)
+        (nullary_cons, nonnullary_cons)
+           | isNewTyCon tycon = ([], tyConDataCons tycon)
+           | otherwise       = partition isNullaryDataCon (tyConDataCons tycon)
 
        rest
          = if (null nullary_cons) then
@@ -301,7 +303,8 @@ gen_Ord_binds tycon
                    (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
 
     (nullary_cons, nonnullary_cons)
-      = partition isNullaryDataCon (tyConDataCons tycon)
+       | isNewTyCon tycon = ([], tyConDataCons tycon)
+       | otherwise       = partition isNullaryDataCon (tyConDataCons tycon)
 
     cmp_eq
       = mk_FunMonoBind tycon_loc cmp_eq_RDR (map pats_etc nonnullary_cons ++
@@ -463,7 +466,7 @@ gen_Bounded_binds tycon
     data_con_N_RDR = qual_orig_name data_con_N
 
     ----- single-constructor-flavored: -------------
-    arity         = dataConNumFields data_con_1
+    arity         = argFieldCount data_con_1
 
     min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
                     mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
@@ -595,7 +598,7 @@ gen_Ix_binds tycon
                     else
                         dc
 
-    con_arity   = dataConNumFields data_con
+    con_arity   = argFieldCount data_con
     data_con_RDR = qual_orig_name data_con
     con_pat  xs = ConPatIn data_con_RDR (map VarPatIn xs)
     con_expr xs = mk_easy_App data_con_RDR xs
@@ -679,11 +682,11 @@ gen_Read_binds tycon
          = let
                data_con_RDR = qual_orig_name data_con
                data_con_str= occNameString (getOccName data_con)
-               con_arity   = dataConNumFields data_con
+               con_arity   = argFieldCount data_con
                as_needed   = take con_arity as_RDRs
                bs_needed   = take con_arity bs_RDRs
                con_expr    = mk_easy_App data_con_RDR as_needed
-               nullary_con = isNullaryDataCon data_con
+               nullary_con = con_arity == 0
 
                con_qual
                  = BindStmt
@@ -745,10 +748,10 @@ gen_Show_binds tycon
        pats_etc data_con
          = let
                data_con_RDR = qual_orig_name data_con
-               con_arity   = dataConNumFields data_con
+               con_arity   = argFieldCount data_con
                bs_needed   = take con_arity bs_RDRs
                con_pat     = ConPatIn data_con_RDR (map VarPatIn bs_needed)
-               nullary_con = isNullaryDataCon data_con
+               nullary_con = con_arity == 0
 
                show_con
                  = let nm = occNameString (getOccName data_con)
@@ -811,7 +814,7 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
       = ASSERT(isDataCon var)
        ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
       where
-       pat    = ConPatIn var_RDR (nOfThem (dataConNumFields var) WildPatIn)
+       pat    = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn)
        var_RDR = qual_orig_name var
 
 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
@@ -868,7 +871,7 @@ mk_easy_Match loc pats binds expr
   = mk_match loc pats expr (mkbind binds)
   where
     mkbind [] = EmptyBinds
-    mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs))
+    mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] recursive
        -- The renamer expects everything in its input to be a
        -- "recursive" MonoBinds, and it is its job to sort things out
        -- from there.
@@ -986,6 +989,11 @@ eq_Expr ty a b
 \end{code}
 
 \begin{code}
+argFieldCount :: Id -> Int     -- Works on data and newtype constructors
+argFieldCount con = length (dataConRawArgTys con)
+\end{code}
+
+\begin{code}
 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
 untag_Expr tycon [] expr = expr
 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
@@ -1044,7 +1052,7 @@ genOpApp e1 op e2 = mkOpApp e1 op e2
 \end{code}
 
 \begin{code}
-qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n }
+qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n HiFile }
 
 a_RDR          = varUnqual SLIT("a")
 b_RDR          = varUnqual SLIT("b")