X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=ddccb2f11f212aa661bebc2b6a5aff15f2cf6d7d;hb=275dde6de685153db621b11f2f404aa78d9183e2;hp=e87cd6643c6ef56ffc0c976bfc9d5f7beb780182;hpb=e8a591c1a3dbdeccec2dd2aacccd7435004b0d51;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index e87cd66..ddccb2f 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -14,7 +14,8 @@ import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), ConDecl(..), Sig(..), NewOrData(..), ResType(..), tyClDeclTyVars, isSynDecl, isClassDecl, isIdxTyDecl, isKindSigDecl, hsConArgs, LTyClDecl, tcdName, - hsTyVarName, LHsTyVarBndr, LHsType + hsTyVarName, LHsTyVarBndr, LHsType, HsType(..), + mkHsAppTy ) import HsTypes ( HsBang(..), getBangStrictness ) import BasicTypes ( RecFlag(..), StrictnessMark(..) ) @@ -50,7 +51,7 @@ import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon, tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, isOpenTyCon, tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName, - isNewTyCon ) + isNewTyCon, tyConKind ) import DataCon ( DataCon, dataConUserType, dataConName, dataConFieldLabels, dataConTyCon, dataConAllTyVars, dataConFieldType, dataConResTys ) @@ -166,22 +167,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 @@ -189,7 +198,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 @@ -204,9 +213,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 @@ -235,12 +248,13 @@ they share a lot of kinding and type checking code with ordinary algebraic data types (and GADTs). \begin{code} -tcIdxTyInstDecl :: LTyClDecl Name -> TcM (Maybe InstInfo) -- Nothing if error +tcIdxTyInstDecl :: LTyClDecl Name + -> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error tcIdxTyInstDecl (L loc decl) = -- Prime error recovery, set source location - recoverM (returnM Nothing) $ - setSrcSpan loc $ - tcAddDeclCtxt decl $ + recoverM (returnM (Nothing, Nothing)) $ + setSrcSpan loc $ + tcAddDeclCtxt decl $ do { -- indexed data types require -fglasgow-exts and can't be in an -- hs-boot file ; gla_exts <- doptM Opt_GlasgowExts @@ -252,50 +266,52 @@ tcIdxTyInstDecl (L loc decl) ; tcIdxTyInstDecl1 decl } -tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe InstInfo) -- Nothing if error +tcIdxTyInstDecl1 :: TyClDecl Name + -> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error tcIdxTyInstDecl1 (decl@TySynonym {}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind -> - do { -- kind check the right hand side of the type equation + = kcIdxTyPats decl $ \k_tvs k_typats resKind _ -> + 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 -- construct type rewrite rule -- !!!of the form: forall t_tvs. (tcdLName decl) t_typats = t_rhs - ; return Nothing -- !!!TODO: need InstInfo for indexed types + ; return (Nothing, Nothing) -- !!!TODO: need InstInfo for eq axioms }} -tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, +tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, tcdCons = cons}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind -> - do { -- kind check the data declaration as usual + = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> + 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 + ; let k_ctxt = tcdCtxt k_decl + k_cons = tcdCons k_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 ; checkTc h98_syntax (badGadtIdxTyDecl tc_name) -- Check that a newtype has exactly one constructor - ; checkTc (new_or_data == DataType || isSingleton cons) $ - newtypeConError tc_name (length cons) + ; checkTc (new_or_data == DataType || isSingleton k_cons) $ + newtypeConError tc_name (length k_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 - tycon t_tvs)) + tycon t_tvs (Just t_typats))) k_cons ; tc_rhs <- case new_or_data of @@ -303,9 +319,8 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, NewType -> ASSERT( isSingleton data_cons ) mkNewTyConRhs tc_name tycon (head data_cons) - --vvvvvvv !!! need a new derived tc_name here ; buildAlgTyCon tc_name t_tvs stupid_theta tc_rhs Recursive - False h98_syntax + False h98_syntax (Just family) -- 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 @@ -314,8 +329,8 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, }) -- construct result - -- !!!twofold: (1) (ATyCon tycon) and (2) an equality axiom - ; return Nothing -- !!!TODO: need InstInfo for indexed types + -- !!!TODO: missing eq axiom + ; return (Nothing, Just (ATyCon tycon)) }} where h98_syntax = case cons of -- All constructors have same shape @@ -332,15 +347,16 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, -- check is only required for type functions. -- kcIdxTyPats :: TyClDecl Name - -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TcM a) + -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a) -- ^^kinded tvs ^^kinded ty pats ^^res kind -> TcM a 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 { family = case tc_ty_thing of + AGlobal (ATyCon family) -> family + ; (kinds, resKind) = splitKindFunTys (tyConKind family) + ; hs_typats = fromJust $ tcdTyPats decl } -- we may not have more parameters than the kind indicates ; checkTc (length kinds >= length hs_typats) $ @@ -349,8 +365,9 @@ kcIdxTyPats decl thing_inside -- type functions can have a higher-kinded result ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind ; typats <- zipWithM kcCheckHsType hs_typats kinds - ; thing_inside tvs typats resultKind + ; thing_inside tvs typats resultKind family } + where \end{code} @@ -589,7 +606,7 @@ tcSynDecl ; 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) @@ -598,20 +615,22 @@ tcTyClDecl calc_isrec decl tcTyClDecl1 _calc_isrec (TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind}) = tcTyVarBndrs tvs $ \ tvs' -> do - { gla_exts <- doptM Opt_GlasgowExts + { traceTc (text "type family: " <+> ppr tc_name) + ; 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))) + ; return [ATyCon (buildSynTyCon tc_name tvs' (OpenSynTyCon kind))] } -- kind signature for an indexed data type tcTyClDecl1 _calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, - tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = []}) + tcdLName = L _ tc_name, tcdKindSig = Just ksig, tcdCons = []}) = tcTyVarBndrs tvs $ \ tvs' -> do - { extra_tvs <- tcDataKindSig mb_ksig + { traceTc (text "data/newtype family: " <+> ppr tc_name) + ; extra_tvs <- tcDataKindSig (Just ksig) ; let final_tvs = tvs' ++ extra_tvs -- we may not need these ; checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name @@ -624,8 +643,8 @@ tcTyClDecl1 _calc_isrec (case new_or_data of DataType -> OpenDataTyCon NewType -> OpenNewTyCon) - Recursive False True - ; return (ATyCon tycon) + Recursive False True Nothing + ; return [ATyCon tycon] } tcTyClDecl1 calc_isrec @@ -660,7 +679,7 @@ tcTyClDecl1 calc_isrec ; tycon <- fixM (\ tycon -> do { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data - tycon final_tvs)) + tycon final_tvs Nothing)) cons ; tc_rhs <- if null cons && is_boot -- In a hs-boot file, empty cons means @@ -671,9 +690,9 @@ tcTyClDecl1 calc_isrec ASSERT( isSingleton 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) h98_syntax + (want_generic && canDoGenerics data_cons) h98_syntax Nothing }) - ; return (ATyCon tycon) + ; return [ATyCon tycon] } where is_rec = calc_isrec tc_name @@ -688,8 +707,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 @@ -698,9 +717,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 ; @@ -709,14 +731,17 @@ 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)) + = returnM [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)] ----------------------------------- tcConDecl :: Bool -- True <=> -funbox-strict_fields - -> NewOrData -> TyCon -> [TyVar] - -> ConDecl Name -> TcM DataCon + -> NewOrData + -> TyCon -> [TyVar] + -> Maybe [Type] -- Just ts <=> type patterns of instance type + -> ConDecl Name + -> TcM DataCon -tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes +tcConDecl unbox_strict NewType tycon tc_tvs mb_typats -- Newtypes (ConDecl name _ ex_tvs ex_ctxt details ResTyH98) = do { let tc_datacon field_lbls arg_ty = do { arg_ty' <- tcHsKindedType arg_ty -- No bang on newtype @@ -726,19 +751,21 @@ tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes tc_tvs [] -- No existentials [] [] -- No equalities, predicates [arg_ty'] - tycon } + tycon + mb_typats} -- Check that a newtype has no existential stuff ; checkTc (null ex_tvs && null (unLoc ex_ctxt)) (newtypeExError name) ; case details of - PrefixCon [arg_ty] -> tc_datacon [] arg_ty + PrefixCon [arg_ty] -> tc_datacon [] arg_ty RecCon [(field_lbl, arg_ty)] -> tc_datacon [field_lbl] arg_ty - other -> failWithTc (newtypeFieldErr name (length (hsConArgs details))) + other -> + failWithTc (newtypeFieldErr name (length (hsConArgs details))) -- Check that the constructor has exactly one field } -tcConDecl unbox_strict DataType tycon tc_tvs -- Data types +tcConDecl unbox_strict DataType tycon tc_tvs mb_typats -- Data types (ConDecl name _ tvs ctxt details res_ty) = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt @@ -751,10 +778,11 @@ tcConDecl unbox_strict DataType tycon tc_tvs -- Data types (argStrictness unbox_strict tycon bangs arg_tys) (map unLoc field_lbls) univ_tvs ex_tvs eq_preds ctxt' arg_tys - data_tc } - -- NB: we put data_tc, the type constructor gotten from the constructor - -- type signature into the data constructor; that way - -- checkValidDataCon can complain if it's wrong. + data_tc + mb_typats} + -- NB: we put data_tc, the type constructor gotten from the + -- constructor type signature into the data constructor; + -- that way checkValidDataCon can complain if it's wrong. ; case details of PrefixCon btys -> tc_datacon False [] btys