Remove the hasGenerics field of TyCon, improve the way the Generics flags is handled...

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

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index a433d69..284972e 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -25,12 +25,10 @@ import TcMType
 import TcType
 import TysWiredIn      ( unitTy )
 import Type
-import Generics
 import Class
 import TyCon
 import DataCon
 import Id
-import MkId            ( mkDefaultMethodId )
 import MkCore          ( rEC_SEL_ERROR_ID )
 import IdInfo
 import Var
@@ -61,12 +59,14 @@ import Data.List
 %************************************************************************
 
 \begin{code}
+
 tcTyAndClassDecls :: ModDetails 
                    -> [[LTyClDecl Name]]     -- Mutually-recursive groups in dependency order
                   -> TcM (TcGblEnv,         -- Input env extended by types and classes 
                                             -- and their implicit Ids,DataCons
                           HsValBinds Name,  -- Renamed bindings for record selectors
-                          [Id])             -- Default method ids
+                          [Id],             -- Default method ids
+                           [LTyClDecl Name]) -- Kind-checked declarations
 -- Fails if there are any errors
 
 tcTyAndClassDecls boot_details decls_s
@@ -89,7 +89,7 @@ tcTyAndClassDecls boot_details decls_s
 
                       -- And now build the TyCons/Classes
                 ; let rec_flags = calcRecFlags boot_details rec_tyclss
-                 ; concatMapM (tcTyClDecl rec_flags) kc_decls }
+                ; concatMapM (tcTyClDecl rec_flags) kc_decls }
 
        ; tcExtendGlobalEnv tyclss $ do
        {  -- Perform the validity check
@@ -109,7 +109,10 @@ tcTyAndClassDecls boot_details decls_s
               ; dm_ids          = mkDefaultMethodIds tyclss }
 
        ; env <- tcExtendGlobalEnv implicit_things getGblEnv
-       ; return (env, rec_sel_binds, dm_ids) } }
+          -- We need the kind-checked declarations later, so we return them
+          -- from here
+        ; kc_decls <- kcTyClDecls tyclds_s
+        ; return (env, rec_sel_binds, dm_ids, kc_decls) } }
                     
 zipRecTyClss :: [[LTyClDecl Name]]
              -> [TyThing]           -- Knot-tied
@@ -268,7 +271,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
                   NewType  -> ASSERT( not (null data_cons) )
                               mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
             ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
-                            False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
+                            h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
                  -- We always assume that indexed types are recursive.  Why?
                  -- (1) Due to their open nature, we can never be sure that a
                  -- further instance might not introduce a new recursive
@@ -488,6 +491,8 @@ kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
   where
     kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
                                   ; return (TypeSig nm op_ty') }
+    kc_sig (GenericSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
+                                     ; return (GenericSig nm op_ty') }
     kc_sig other_sig         = return other_sig
 
 kcTyClDecl decl@(ForeignType {})
@@ -634,7 +639,7 @@ tcTyClDecl1 parent _calc_isrec
   ; checkTc idx_tys $ badFamInstDecl tc_name
 
   ; tycon <- buildAlgTyCon tc_name final_tvs [] 
-               DataFamilyTyCon Recursive False True 
+               DataFamilyTyCon Recursive True 
                parent Nothing
   ; return [ATyCon tycon]
   }
@@ -660,7 +665,6 @@ tcTyClDecl1 _parent calc_isrec
   { extra_tvs <- tcDataKindSig mb_ksig
   ; let final_tvs = tvs' ++ extra_tvs
   ; stupid_theta <- tcHsKindedContext ctxt
-  ; want_generic <- xoptM Opt_Generics
   ; unbox_strict <- doptM Opt_UnboxStrictFields
   ; empty_data_decls <- xoptM Opt_EmptyDataDecls
   ; kind_signatures <- xoptM Opt_KindSignatures
@@ -702,8 +706,7 @@ tcTyClDecl1 _parent calc_isrec
                   NewType  -> ASSERT( not (null data_cons) )
                                mkNewTyConRhs tc_name tycon (head data_cons)
        ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
-           (want_generic && canDoGenerics data_cons) (not h98_syntax) 
-            NoParentTyCon Nothing
+           (not h98_syntax) NoParentTyCon Nothing
        })
   ; return [ATyCon tycon]
   }
@@ -1134,9 +1137,9 @@ checkValidClass cls
   where
     (tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls
     unary      = isSingleton tyvars
-    no_generics = null [() | (_, GenDefMeth) <- op_stuff]
+    no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff]
 
-    check_op constrained_class_methods (sel_id, dm) 
+    check_op constrained_class_methods (sel_id, _) 
       = addErrCtxt (classOpCtxt sel_id tau) $ do
        { checkValidTheta SigmaCtxt (tail theta)
                -- The 'tail' removes the initial (C a) from the
@@ -1157,8 +1160,10 @@ checkValidClass cls
 
                -- Check that for a generic method, the type of 
                -- the method is sufficiently simple
+{- -- JPM TODO  (when reinstating, remove commenting-out of badGenericMethodType
        ; checkTc (dm /= GenDefMeth || validGenericMethodType tau)
                  (badGenericMethodType op_name op_ty)
+-}
        }
        where
          op_name = idName sel_id
@@ -1186,7 +1191,7 @@ checkValidClass cls
 mkDefaultMethodIds :: [TyThing] -> [Id]
 -- See Note [Default method Ids and Template Haskell]
 mkDefaultMethodIds things
-  = [ mkDefaultMethodId sel_id dm_name
+  = [ mkExportedLocalId dm_name (idType sel_id)
     | AClass cls <- things
     , (sel_id, DefMeth dm_name) <- classOpItems cls ]
 \end{code}
@@ -1424,11 +1429,13 @@ genericMultiParamErr clas
   = ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+> 
     ptext (sLit "cannot have generic methods")
 
+{-  Commented out until the call is reinstated
 badGenericMethodType :: Name -> Kind -> SDoc
 badGenericMethodType op op_ty
   = hang (ptext (sLit "Generic method type is too complex"))
        2 (vcat [ppr op <+> dcolon <+> ppr op_ty,
                ptext (sLit "You can only use type variables, arrows, lists, and tuples")])
+-}
 
 recSynErr :: [LTyClDecl Name] -> TcRn ()
 recSynErr syn_decls