Add a new flag XDefaultSignatures to enable just the signatures on the default method...

[ghc-hetmet.git] / compiler / types / Generics.lhs

diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs
index b17670d..50b6b96 100644 (file)
--- a/compiler/types/Generics.lhs
+++ b/compiler/types/Generics.lhs
@@ -42,18 +42,18 @@ import FastString
 %************************************************************************
 
 \begin{code}
-canDoGenerics :: ThetaType -> [DataCon] -> Bool
+canDoGenerics :: TyCon -> Bool
 -- Called on source-code data types, to see if we should generate
--- generic functions for them.  (This info is recorded in the interface file for
--- imported data types.)
-
-canDoGenerics stupid_theta data_cs
-  =  not (any bad_con data_cs)         -- See comment below
-  
-  -- && not (null data_cs)     -- No values of the type
-  -- JPM: we now support empty datatypes
-  
-     && null stupid_theta -- We do not support datatypes with context (for now)
+-- generic functions for them.
+
+canDoGenerics tycon
+  =  let result = not (any bad_con (tyConDataCons tycon))      -- See comment below
+                  -- We do not support datatypes with context (for now)
+                  && null (tyConStupidTheta tycon)
+                  -- We don't like type families
+                  && not (isFamilyTyCon tycon)
+
+     in {- pprTrace "canDoGenerics" (ppr (tycon,result)) -} result
   where
     bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
        -- If any of the constructor has an unboxed type as argument,
@@ -65,8 +65,6 @@ canDoGenerics stupid_theta data_cs
 
        -- Nor if the args are polymorphic types (I don't think)
     bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
-  -- JPM: TODO: I'm not sure I know what isTauTy checks for, so I'm leaving it
-       -- like this for now...
 \end{code}
 
 %************************************************************************
@@ -107,14 +105,15 @@ tc_mkRep0Ty :: -- The type to generate representation for
             -> TcM Type
 tc_mkRep0Ty tycon metaDts = 
   do
-    d1 <- tcLookupTyCon d1TyConName
-    c1 <- tcLookupTyCon c1TyConName
-    s1 <- tcLookupTyCon s1TyConName
-    rec0 <- tcLookupTyCon rec0TyConName
-    par0 <- tcLookupTyCon par0TyConName
-    u1 <- tcLookupTyCon u1TyConName
-    v1 <- tcLookupTyCon v1TyConName
-    plus <- tcLookupTyCon sumTyConName
+    d1    <- tcLookupTyCon d1TyConName
+    c1    <- tcLookupTyCon c1TyConName
+    s1    <- tcLookupTyCon s1TyConName
+    nS1   <- tcLookupTyCon noSelTyConName
+    rec0  <- tcLookupTyCon rec0TyConName
+    par0  <- tcLookupTyCon par0TyConName
+    u1    <- tcLookupTyCon u1TyConName
+    v1    <- tcLookupTyCon v1TyConName
+    plus  <- tcLookupTyCon sumTyConName
     times <- tcLookupTyCon prodTyConName
     
     let mkSum' a b = mkTyConApp plus  [a,b]
@@ -122,23 +121,29 @@ tc_mkRep0Ty tycon metaDts =
         mkRec0 a   = mkTyConApp rec0  [a]
         mkPar0 a   = mkTyConApp par0  [a]
         mkD    a   = mkTyConApp d1    [metaDTyCon, sumP (tyConDataCons a)]
-        mkC  i d a = mkTyConApp c1    [d, prod i (dataConOrigArgTys a)]
-        mkS    d a = mkTyConApp s1    [d, a]
+        mkC  i d a = mkTyConApp c1    [d, prod i (dataConOrigArgTys a) 
+                                                 (null (dataConFieldLabels a))]
+        -- This field has no label
+        mkS True  _ a = mkTyConApp s1 [mkTyConTy nS1, a]
+        -- This field has a  label
+        mkS False d a = mkTyConApp s1 [d, a]
         
         sumP [] = mkTyConTy v1
         sumP l  = ASSERT (length metaCTyCons == length l)
                     foldBal mkSum' [ mkC i d a
                                    | (d,(a,i)) <- zip metaCTyCons (zip l [0..])]
-        prod :: Int -> [Type] -> Type
-        prod i [] = ASSERT (length metaSTyCons > i)
-                      ASSERT (length (metaSTyCons !! i) == 0)
-                        mkTyConTy u1
-        prod i l  = ASSERT (length metaSTyCons > i)
-                      ASSERT (length l == length (metaSTyCons !! i))
-                        foldBal mkProd [ arg d a 
-                                       | (d,a) <- zip (metaSTyCons !! i) l ]
+        -- The Bool is True if this constructor has labelled fields
+        prod :: Int -> [Type] -> Bool -> Type
+        prod i [] _ = ASSERT (length metaSTyCons > i)
+                        ASSERT (length (metaSTyCons !! i) == 0)
+                          mkTyConTy u1
+        prod i l b  = ASSERT (length metaSTyCons > i)
+                        ASSERT (length l == length (metaSTyCons !! i))
+                          foldBal mkProd [ arg d t b
+                                         | (d,t) <- zip (metaSTyCons !! i) l ]
         
-        arg d t = mkS d (recOrPar t (getTyVar_maybe t))
+        arg :: Type -> Type -> Bool -> Type
+        arg d t b = mkS b d (recOrPar t (getTyVar_maybe t))
         -- Argument is not a type variable, use Rec0
         recOrPar t Nothing  = mkRec0 t
         -- Argument is a type variable, use Par0