X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=ccefb00d575667c5837030f538a89262e631665b;hb=a4572b40a9668d949b906c000e40d65ca9dc2798;hp=8ca5b01e81aef9ed5992379a1b568c2af3ff8024;hpb=202ac08f3e2afde0620e889cc81a95b2fd0ad9e1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 8ca5b01..ccefb00 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -44,10 +44,13 @@ import Type ( PredType(..), splitTyConApp_maybe, mkTyVarTy, ) import Generics ( validGenericMethodType, canDoGenerics ) import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars ) -import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon ), - tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, +import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon, + OpenNewTyCon ), + SynTyConRhs( OpenSynTyCon, SynonymTyCon ), + tyConDataCons, mkForeignTyCon, isProductTyCon, + isRecursiveTyCon, isOpenTyCon, tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName, - isNewTyCon ) + isNewTyCon, tyConKind ) import DataCon ( DataCon, dataConUserType, dataConName, dataConFieldLabels, dataConTyCon, dataConAllTyVars, dataConFieldType, dataConResTys ) @@ -163,22 +166,30 @@ tcTyAndClassDecls boot_details allDecls ; mod <- getModule ; traceTc (text "tcTyAndCl" <+> ppr mod) ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) -> - do { let { -- Calculate variances and rec-flag + do { let { -- Seperate ordinary synonyms from all other type and + -- class declarations and add all associated type + -- declarations from type classes. The latter is + -- required so that the temporary environment for the + -- knot includes all associated family declarations. ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) - decls } + decls + ; alg_at_decls = concatMap addATs alg_decls + } -- Extend the global env with the knot-tied results -- for data types and classes -- - -- We must populate the environment with the loop-tied T's right - -- away, because the kind checker may "fault in" some type - -- constructors that recursively mention T - ; let { gbl_things = mkGlobalThings alg_decls rec_alg_tyclss } + -- We must populate the environment with the loop-tied + -- T's right away, because the kind checker may "fault + -- in" some type constructors that recursively + -- mention T + ; let gbl_things = mkGlobalThings alg_at_decls rec_alg_tyclss ; tcExtendRecEnv gbl_things $ do -- Kind-check the declarations { (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls - ; let { calc_rec = calcRecFlags boot_details rec_alg_tyclss + ; let { -- Calculate rec-flag + ; 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 kc_syn_decls @@ -186,7 +197,7 @@ tcTyAndClassDecls boot_details allDecls -- Type-check the data types and classes { alg_tyclss <- mappM tc_decl kc_alg_decls - ; return (syn_tycons, alg_tyclss) + ; return (syn_tycons, concat alg_tyclss) }}}) -- Finished with knot-tying now -- Extend the environment with the finished things @@ -201,9 +212,13 @@ tcTyAndClassDecls boot_details allDecls -- we want them in the environment because -- they may be mentioned in interface files ; let { implicit_things = concatMap implicitTyThings alg_tyclss } - ; traceTc ((text "Adding" <+> ppr alg_tyclss) $$ (text "and" <+> ppr implicit_things)) + ; traceTc ((text "Adding" <+> ppr alg_tyclss) + $$ (text "and" <+> ppr implicit_things)) ; tcExtendGlobalEnv implicit_things getGblEnv }} + where + addATs decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats + addATs decl = [decl] mkGlobalThings :: [LTyClDecl Name] -- The decls -> [TyThing] -- Knot-tied, in 1-1 correspondence with the decls @@ -253,11 +268,11 @@ tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe InstInfo) -- Nothing if error tcIdxTyInstDecl1 (decl@TySynonym {}) = kcIdxTyPats decl $ \k_tvs k_typats resKind -> - do { -- kind check the right hand side of the type equation + do { -- (1) kind check the right hand side of the type equation ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind - -- type check type equation - ; tcTyVarBndrs k_tvs $ \t_tvs -> do { + -- (2) type check type equation + ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars ; t_typats <- mappM tcHsKindedType k_typats ; t_rhs <- tcHsKindedType k_rhs @@ -269,17 +284,16 @@ tcIdxTyInstDecl1 (decl@TySynonym {}) tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, tcdCons = cons}) = kcIdxTyPats decl $ \k_tvs k_typats resKind -> - do { -- kind check the data declaration as usual + do { -- (1) kind check the data declaration as usual ; k_decl <- kcDataDecl decl k_tvs - ; k_typats <- mappM tcHsKindedType k_typats ; let k_ctxt = tcdCtxt decl k_cons = tcdCons decl -- result kind must be '*' (otherwise, we have too few patterns) ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr tc_name - -- type check indexed data type declaration - ; tcTyVarBndrs k_tvs $ \t_tvs -> do { + -- (2) type check indexed data type declaration + ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars ; unbox_strict <- doptM Opt_UnboxStrictFields -- Check that we don't use GADT syntax for indexed types @@ -289,6 +303,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, ; checkTc (new_or_data == DataType || isSingleton cons) $ newtypeConError tc_name (length cons) + ; t_typats <- mappM tcHsKindedType k_typats ; stupid_theta <- tcHsKindedContext k_ctxt ; tycon <- fixM (\ tycon -> do { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data @@ -335,9 +350,10 @@ kcIdxTyPats :: TyClDecl Name kcIdxTyPats decl thing_inside = kcHsTyVars (tcdTyVars decl) $ \tvs -> do { tc_ty_thing <- tcLookupLocated (tcdLName decl) - ; let tc_kind = case tc_ty_thing of { AThing k -> k } - (kinds, resKind) = splitKindFunTys tc_kind - hs_typats = fromJust $ tcdTyPats decl + ; let { tc_kind = case tc_ty_thing of + AGlobal (ATyCon tycon) -> tyConKind tycon + ; (kinds, resKind) = splitKindFunTys tc_kind + ; hs_typats = fromJust $ tcdTyPats decl } -- we may not have more parameters than the kind indicates ; checkTc (length kinds >= length hs_typats) $ @@ -348,6 +364,7 @@ kcIdxTyPats decl thing_inside ; typats <- zipWithM kcCheckHsType hs_typats kinds ; thing_inside tvs typats resultKind } + where \end{code} @@ -583,26 +600,46 @@ tcSynDecl = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "tcd1" <+> ppr tc_name) ; rhs_ty' <- tcHsKindedType rhs_ty - ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty')) } + ; return (ATyCon (buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty'))) } -------------------- -tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM TyThing +tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing] tcTyClDecl calc_isrec decl = tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl) - -- kind signature for a type functions + -- kind signature for a type function tcTyClDecl1 _calc_isrec (TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind}) - = tcKindSigDecl tc_name tvs kind + = tcTyVarBndrs tvs $ \ tvs' -> do + { gla_exts <- doptM Opt_GlasgowExts + + -- Check that we don't use kind signatures without Glasgow extensions + ; checkTc gla_exts $ badSigTyDecl tc_name + + ; return [ATyCon (buildSynTyCon tc_name tvs' (OpenSynTyCon kind))] + } -- kind signature for an indexed data type tcTyClDecl1 _calc_isrec - (TyData {tcdCtxt = ctxt, tcdTyVars = tvs, - tcdLName = L _ tc_name, tcdKindSig = Just kind, tcdCons = []}) - = do - { checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name - ; tcKindSigDecl tc_name tvs kind + (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, + tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = []}) + = tcTyVarBndrs tvs $ \ tvs' -> do + { extra_tvs <- tcDataKindSig mb_ksig + ; let final_tvs = tvs' ++ extra_tvs -- we may not need these + + ; checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name + ; gla_exts <- doptM Opt_GlasgowExts + + -- Check that we don't use kind signatures without Glasgow extensions + ; checkTc gla_exts $ badSigTyDecl tc_name + + ; tycon <- buildAlgTyCon tc_name final_tvs [] + (case new_or_data of + DataType -> OpenDataTyCon + NewType -> OpenNewTyCon) + Recursive False True + ; return [ATyCon tycon] } tcTyClDecl1 calc_isrec @@ -650,7 +687,7 @@ tcTyClDecl1 calc_isrec ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec (want_generic && canDoGenerics data_cons) h98_syntax }) - ; return (ATyCon tycon) + ; return [ATyCon tycon] } where is_rec = calc_isrec tc_name @@ -665,8 +702,8 @@ tcTyClDecl1 calc_isrec = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; fds' <- mappM (addLocM tc_fundep) fundeps - ; ats' <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats - -- ^^^^ !!!TODO: what to do with this? Need to generate FC tyfun decls. + ; atss <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats + ; let ats' = concat atss ; sig_stuff <- tcClassSigs class_name sigs meths ; clas <- fixM (\ clas -> let -- This little knot is just so we can get @@ -675,9 +712,12 @@ tcTyClDecl1 calc_isrec tycon_name = tyConName (classTyCon clas) tc_isrec = calc_isrec tycon_name in - buildClass class_name tvs' ctxt' fds' + buildClass class_name tvs' ctxt' fds' ats' sig_stuff tc_isrec) - ; return (AClass clas) } + ; return (AClass clas : ats') + -- NB: Order is important due to the call to `mkGlobalThings' when + -- tying the the type and class declaration type checking knot. + } where tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ; ; tvs2' <- mappM tcLookupTyVar tvs2 ; @@ -686,29 +726,7 @@ tcTyClDecl1 calc_isrec tcTyClDecl1 calc_isrec (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) - = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)) - ------------------------------------ -tcKindSigDecl :: Name -> [LHsTyVarBndr Name] -> Kind -> TcM TyThing -tcKindSigDecl tc_name tvs kind - = tcTyVarBndrs tvs $ \ tvs' -> do - { gla_exts <- doptM Opt_GlasgowExts - - -- Check that we don't use kind signatures without Glasgow extensions - ; checkTc gla_exts $ badSigTyDecl tc_name - - -- !!!TODO - -- We need to extend TyCon.TyCon with a new variant representing indexed - -- type constructors (ie, IdxTyCon). We will use them for both indexed - -- data types as well as type functions. In the case of indexed *data* - -- types, they are *abstract*; ie, won't be rewritten. OR do we just want - -- to make another variant of AlgTyCon (after all synonyms are also - -- AlgTyCons...) - -- We need an additional argument to this functions, which determines - -- whether the type constructor is abstract. - ; tycon <- error "TcTyClsDecls.tcKindSigDecl: IdxTyCon not implemented yet." - ; return (ATyCon tycon) - } + = returnM [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)] ----------------------------------- tcConDecl :: Bool -- True <=> -funbox-strict_fields @@ -887,7 +905,9 @@ checkValidTyCl decl checkValidTyCon :: TyCon -> TcM () checkValidTyCon tc | isSynTyCon tc - = checkValidType syn_ctxt syn_rhs + = case synTyConRhs tc of + OpenSynTyCon _ -> return () + SynonymTyCon ty -> checkValidType syn_ctxt ty | otherwise = -- Check the context on the data decl checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) `thenM_` @@ -901,7 +921,6 @@ checkValidTyCon tc where syn_ctxt = TySynCtxt name name = tyConName tc - syn_rhs = synTyConRhs tc data_cons = tyConDataCons tc groups = equivClasses cmp_fld (concatMap get_fields data_cons)