X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=090db01ca69fa36155d25d93cb5a1438dc3694a6;hp=cf9900a43c8cdead2f2f2da826942a5b7af488d0;hb=3e0b6b2542d8464bfba365b97a6e4b95c3885f10;hpb=8c839b096be9a3fd44f4f681ed7f14fd95fe8ff9 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index cf9900a..090db01 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -12,7 +12,7 @@ module TcTyClsDecls ( import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), ConDecl(..), Sig(..), NewOrData(..), ResType(..), - tyClDeclTyVars, isSynDecl, hsConArgs, + tyClDeclTyVars, isSynDecl, isClassDecl, hsConArgs, LTyClDecl, tcdName, hsTyVarName, LHsTyVarBndr ) import HsTypes ( HsBang(..), getBangStrictness ) @@ -24,8 +24,8 @@ import TcRnMonad import TcEnv ( TyThing(..), tcLookupLocated, tcLookupLocatedGlobal, tcExtendGlobalEnv, tcExtendKindEnv, tcExtendKindEnvTvs, - tcExtendRecEnv, tcLookupTyVar ) -import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcClassCycles, calcSynCycles ) + tcExtendRecEnv, tcLookupTyVar, InstInfo ) +import TcTyDecls ( calcRecFlags, calcClassCycles, calcSynCycles ) import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType, kcHsContext, tcTyVarBndrs, tcHsKindedType, tcHsKindedContext, @@ -42,7 +42,7 @@ import Type ( splitTyConApp_maybe, import Kind ( mkArrowKinds, splitKindFunTys ) import Generics ( validGenericMethodType, canDoGenerics ) import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars ) -import TyCon ( TyCon, ArgVrcs, AlgTyConRhs( AbstractTyCon ), +import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon ), tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName ) import DataCon ( DataCon, dataConWrapId, dataConName, @@ -111,9 +111,39 @@ Step 7: checkValidTyCl to check all the side conditions on validity. We could not do this before because we were in a mutually recursive knot. - +Identification of recursive TyCons +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to -@TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s. +@TyThing@s. + +Identifying a TyCon as recursive serves two purposes + +1. Avoid infinite types. Non-recursive newtypes are treated as +"transparent", like type synonyms, after the type checker. If we did +this for all newtypes, we'd get infinite types. So we figure out for +each newtype whether it is "recursive", and add a coercion if so. In +effect, we are trying to "cut the loops" by identifying a loop-breaker. + +2. Avoid infinite unboxing. This is nothing to do with newtypes. +Suppose we have + data T = MkT Int T + f (MkT x t) = f t +Well, this function diverges, but we don't want the strictness analyser +to diverge. But the strictness analyser will diverge because it looks +deeper and deeper into the structure of T. (I believe there are +examples where the function does something sane, and the strictness +analyser still diverges, but I can't see one now.) + +Now, concerning (1), the FC2 branch currently adds a coercion for ALL +newtypes. I did this as an experiment, to try to expose cases in which +the coercions got in the way of optimisations. If it turns out that we +can indeed always use a coercion, then we don't risk recursive types, +and don't need to figure out what the loop breakers are. + +For newtype *families* though, we will always have a coercion, so they +are always loop breakers! So you can easily adjust the current +algorithm by simply treating all newtype families as loop breakers (and +indeed type families). I think. \begin{code} tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name] @@ -127,8 +157,8 @@ tcTyAndClassDecls boot_details decls ; traceTc (text "tcTyAndCl" <+> ppr mod) ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) -> do { let { -- Calculate variances and rec-flag - ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls } - + ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) + decls } -- Extend the global env with the knot-tied results -- for data types and classes -- @@ -141,11 +171,10 @@ tcTyAndClassDecls boot_details decls -- Kind-check the declarations { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls - ; let { calc_vrcs = calcTyConArgVrcs (rec_syn_tycons ++ rec_alg_tyclss) - ; calc_rec = calcRecFlags boot_details rec_alg_tyclss - ; tc_decl = addLocM (tcTyClDecl calc_vrcs calc_rec) } + ; let { calc_rec = calcRecFlags boot_details rec_alg_tyclss + ; tc_decl = addLocM (tcTyClDecl calc_rec) } -- Type-check the type synonyms, and extend the envt - ; syn_tycons <- tcSynDecls calc_vrcs kc_syn_decls + ; syn_tycons <- tcSynDecls kc_syn_decls ; tcExtendGlobalEnv syn_tycons $ do -- Type-check the data types and classes @@ -320,6 +349,7 @@ kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) -- going to remove the constructor while coercing it to a lifted type. -- And newtypes can't be bang'd +-- !!!TODO -=chak kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs}) = kcTyClDeclBody decl $ \ tvs' -> do { is_boot <- tcIsHsBoot @@ -362,28 +392,27 @@ kcTyClDeclBody decl thing_inside %************************************************************************ \begin{code} -tcSynDecls :: (Name -> ArgVrcs) -> [LTyClDecl Name] -> TcM [TyThing] -tcSynDecls calc_vrcs [] = return [] -tcSynDecls calc_vrcs (decl : decls) - = do { syn_tc <- addLocM (tcSynDecl calc_vrcs) decl - ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls calc_vrcs decls) +tcSynDecls :: [LTyClDecl Name] -> TcM [TyThing] +tcSynDecls [] = return [] +tcSynDecls (decl : decls) + = do { syn_tc <- addLocM tcSynDecl decl + ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls) ; return (syn_tc : syn_tcs) } -tcSynDecl calc_vrcs +tcSynDecl (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "tcd1" <+> ppr tc_name) ; rhs_ty' <- tcHsKindedType rhs_ty - ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' (calc_vrcs tc_name))) } + ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty')) } -------------------- -tcTyClDecl :: (Name -> ArgVrcs) -> (Name -> RecFlag) - -> TyClDecl Name -> TcM TyThing +tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM TyThing -tcTyClDecl calc_vrcs calc_isrec decl - = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec decl) +tcTyClDecl calc_isrec decl + = tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl) -tcTyClDecl1 calc_vrcs calc_isrec +tcTyClDecl1 calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons}) = tcTyVarBndrs tvs $ \ tvs' -> do @@ -419,25 +448,25 @@ tcTyClDecl1 calc_vrcs calc_isrec DataType -> mkDataTyConRhs data_cons NewType -> ASSERT( isSingleton data_cons ) mkNewTyConRhs tycon (head data_cons) - ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs arg_vrcs is_rec + ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec (want_generic && canDoGenerics data_cons) }) ; return (ATyCon tycon) } where - arg_vrcs = calc_vrcs tc_name is_rec = calc_isrec tc_name h98_syntax = case cons of -- All constructors have same shape L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False other -> True -tcTyClDecl1 calc_vrcs calc_isrec +tcTyClDecl1 calc_isrec (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, tcdCtxt = ctxt, tcdMeths = meths, - tcdFDs = fundeps, tcdSigs = sigs} ) + tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} ) = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; fds' <- mappM (addLocM tc_fundep) fundeps + -- !!!TODO: process `ats`; what do we want to store in the `Class'? -=chak ; sig_stuff <- tcClassSigs class_name sigs meths ; clas <- fixM (\ clas -> let -- This little knot is just so we can get @@ -445,10 +474,9 @@ tcTyClDecl1 calc_vrcs calc_isrec -- need to look up its recursiveness and variance tycon_name = tyConName (classTyCon clas) tc_isrec = calc_isrec tycon_name - tc_vrcs = calc_vrcs tycon_name in buildClass class_name tvs' ctxt' fds' - sig_stuff tc_isrec tc_vrcs) + sig_stuff tc_isrec) ; return (AClass clas) } where tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ; @@ -456,9 +484,9 @@ tcTyClDecl1 calc_vrcs calc_isrec ; return (tvs1', tvs2') } -tcTyClDecl1 calc_vrcs calc_isrec +tcTyClDecl1 calc_isrec (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) - = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 [])) + = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)) ----------------------------------- tcConDecl :: Bool -- True <=> -funbox-strict_fields @@ -630,7 +658,7 @@ checkValidTyCon tc get_fields con = dataConFieldLabels con `zip` repeat con -- dataConFieldLabels may return the empty list, which is fine - -- XXX - autrijus - Make this far more complex to acommodate + -- Note: The complicated checkOne logic below is there to accomodate -- for different return types. Add res_ty to the mix, -- comparing them in two steps, all for good error messages. -- Plan: Use Unify.tcMatchTys to compare the first candidate's @@ -704,11 +732,15 @@ checkValidClass cls -- class has only one parameter. We can't do generic -- multi-parameter type classes! ; checkTc (unary || no_generics) (genericMultiParamErr cls) + + -- Check that the class has no associated types, unless GlaExs + ; checkTc (gla_exts || no_ats) (badATDecl cls) } where (tyvars, theta, _, op_stuff) = classBigSig cls unary = isSingleton tyvars no_generics = null [() | (_, GenDefMeth) <- op_stuff] + no_ats = True -- !!!TODO: determine whether the class has ATs -=chak check_op gla_exts (sel_id, dm) = addErrCtxt (classOpCtxt sel_id tau) $ do @@ -820,6 +852,10 @@ newtypeFieldErr con_name n_flds = sep [ptext SLIT("The constructor of a newtype must have exactly one field"), nest 2 $ ptext SLIT("but") <+> quotes (ppr con_name) <+> ptext SLIT("has") <+> speakN n_flds] +badATDecl cl_name + = vcat [ ptext SLIT("Illegal associated type declaration in") <+> quotes (ppr cl_name) + , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow ATs")) ] + emptyConDeclsErr tycon = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), nest 2 $ ptext SLIT("(-fglasgow-exts permits this)")]