X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=284972e7a3a64a5cfe5346a3c115fbe55cb2018b;hb=924142621ebc30a3c16368e0df3466ee14185ddd;hp=a433d697b9d8d5667899e15968f32ae517134833;hpb=6ea06bbf08517d9805feb82df65cc56ecbaf23a4;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index a433d69..284972e 100644 --- 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