X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=3c25a7fa2712627578380bda0c7d48ef5c3c81a2;hp=ccefb00d575667c5837030f538a89262e631665b;hb=138b885a335734039daf7debb0a7dfc3dc947c00;hpb=f94a8dbd393b518679807a359ca27d0f3418a3a5 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index ccefb00..3c25a7f 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -14,9 +14,10 @@ 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 HsTypes ( HsBang(..), getBangStrictness, hsLTyVarNames ) import BasicTypes ( RecFlag(..), StrictnessMark(..) ) import HscTypes ( implicitTyThings, ModDetails ) import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon, @@ -24,8 +25,9 @@ import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon, import TcRnMonad import TcEnv ( TyThing(..), tcLookupLocated, tcLookupLocatedGlobal, - tcExtendGlobalEnv, tcExtendKindEnv, tcExtendKindEnvTvs, - tcExtendRecEnv, tcLookupTyVar, InstInfo ) + tcExtendGlobalEnv, tcExtendKindEnv, + tcExtendKindEnvTvs, newFamInstTyConName, + tcExtendRecEnv, tcLookupTyVar, tcLookupLocatedTyCon ) import TcTyDecls ( calcRecFlags, calcClassCycles, calcSynCycles ) import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType, @@ -50,7 +52,8 @@ import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon, tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, isOpenTyCon, tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName, - isNewTyCon, tyConKind ) + isNewTyCon, isDataTyCon, tyConKind, + setTyConArgPoss ) import DataCon ( DataCon, dataConUserType, dataConName, dataConFieldLabels, dataConTyCon, dataConAllTyVars, dataConFieldType, dataConResTys ) @@ -58,17 +61,18 @@ import Var ( TyVar, idType, idName ) import VarSet ( elemVarSet, mkVarSet ) import Name ( Name, getSrcLoc ) import Outputable -import Maybe ( isJust, fromJust, isNothing ) +import Maybe ( isJust, fromJust, isNothing, catMaybes ) import Maybes ( expectJust ) +import Monad ( unless ) import Unify ( tcMatchTys, tcMatchTyX ) import Util ( zipLazy, isSingleton, notNull, sortLe ) -import List ( partition ) -import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan ) +import List ( partition, elemIndex ) +import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan, + srcSpanStart ) import ListSetOps ( equivClasses, minusList ) -import List ( delete ) import Digraph ( SCC(..) ) import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics, - Opt_UnboxStrictFields ) ) + Opt_UnboxStrictFields, Opt_IndexedTypes ) ) \end{code} @@ -211,12 +215,20 @@ tcTyAndClassDecls boot_details allDecls -- Add the implicit things; -- we want them in the environment because -- they may be mentioned in interface files + -- NB: All associated types and their implicit things will be added a + -- second time here. This doesn't matter as the definitions are + -- the same. ; let { implicit_things = concatMap implicitTyThings alg_tyclss } ; traceTc ((text "Adding" <+> ppr alg_tyclss) $$ (text "and" <+> ppr implicit_things)) ; tcExtendGlobalEnv implicit_things getGblEnv }} where + -- Pull associated types out of class declarations, to tie them into the + -- knot above. + -- NB: We put them in the same place in the list as `tcTyClDecl' will + -- eventually put the matching `TyThing's. That's crucial; otherwise, + -- the two argument lists of `mkGlobalThings' don't match up. addATs decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats addATs decl = [decl] @@ -247,15 +259,15 @@ 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 TyThing) -- Nothing if error tcIdxTyInstDecl (L loc decl) = -- Prime error recovery, set source location - recoverM (returnM Nothing) $ - setSrcSpan loc $ - tcAddDeclCtxt decl $ - do { -- indexed data types require -fglasgow-exts and can't be in an + recoverM (returnM Nothing) $ + setSrcSpan loc $ + tcAddDeclCtxt decl $ + do { -- indexed data types require -findexed-types and can't be in an -- hs-boot file - ; gla_exts <- doptM Opt_GlasgowExts + ; gla_exts <- doptM Opt_IndexedTypes ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? ; checkTc gla_exts $ badIdxTyDecl (tcdLName decl) ; checkTc (not is_boot) $ badBootTyIdxDeclErr @@ -264,11 +276,15 @@ tcIdxTyInstDecl (L loc decl) ; tcIdxTyInstDecl1 decl } -tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe InstInfo) -- Nothing if error +tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error tcIdxTyInstDecl1 (decl@TySynonym {}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind -> - do { -- (1) kind check the right hand side of the type equation + = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> + do { -- check that the family declaration is for a synonym + unless (isSynTyCon family) $ + addErr (wrongKindOfFamily family) + + ; -- (1) kind check the right hand side of the type equation ; k_rhs <- kcCheckHsType (tcdSynRhs decl) resKind -- (2) type check type equation @@ -276,18 +292,22 @@ tcIdxTyInstDecl1 (decl@TySynonym {}) ; 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 -- !!!TODO: need TyThing for indexed synonym }} -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 { -- (1) kind check the data declaration as usual + = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> + do { -- check that the family declaration is for the right kind + unless (new_or_data == NewType && isNewTyCon family || + new_or_data == DataType && isDataTyCon family) $ + addErr (wrongKindOfFamily family) + + ; -- (1) kind check the data declaration as usual ; k_decl <- kcDataDecl decl k_tvs - ; 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 @@ -300,24 +320,24 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L _ tc_name, ; 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 + + ; rep_tc_name <- newFamInstTyConName tc_name (srcSpanStart loc) ; tycon <- fixM (\ tycon -> do { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data - tycon t_tvs)) + tycon t_tvs)) k_cons ; tc_rhs <- case new_or_data of DataType -> return (mkDataTyConRhs data_cons) - 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 + NewType -> ASSERT( isSingleton data_cons ) + mkNewTyConRhs tc_name tycon (head data_cons) + ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive + False h98_syntax (Just (family, 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 @@ -326,8 +346,7 @@ 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 + ; return $ Just (ATyCon tycon) }} where h98_syntax = case cons of -- All constructors have same shape @@ -344,15 +363,13 @@ 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 - AGlobal (ATyCon tycon) -> tyConKind tycon - ; (kinds, resKind) = splitKindFunTys tc_kind + do { family <- tcLookupLocatedTyCon (tcdLName decl) + ; let { (kinds, resKind) = splitKindFunTys (tyConKind family) ; hs_typats = fromJust $ tcdTyPats decl } -- we may not have more parameters than the kind indicates @@ -362,7 +379,7 @@ 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} @@ -612,24 +629,26 @@ 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_IndexedTypes -- 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 - ; gla_exts <- doptM Opt_GlasgowExts + ; gla_exts <- doptM Opt_IndexedTypes -- Check that we don't use kind signatures without Glasgow extensions ; checkTc gla_exts $ badSigTyDecl tc_name @@ -638,7 +657,7 @@ tcTyClDecl1 _calc_isrec (case new_or_data of DataType -> OpenDataTyCon NewType -> OpenNewTyCon) - Recursive False True + Recursive False True Nothing ; return [ATyCon tycon] } @@ -685,7 +704,7 @@ 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] } @@ -703,7 +722,7 @@ tcTyClDecl1 calc_isrec { ctxt' <- tcHsKindedContext ctxt ; fds' <- mappM (addLocM tc_fundep) fundeps ; atss <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats - ; let ats' = concat atss + ; let ats' = zipWith setTyThingPoss atss (map (tcdTyVars . unLoc) ats) ; sig_stuff <- tcClassSigs class_name sigs meths ; clas <- fixM (\ clas -> let -- This little knot is just so we can get @@ -723,6 +742,19 @@ tcTyClDecl1 calc_isrec ; tvs2' <- mappM tcLookupTyVar tvs2 ; ; return (tvs1', tvs2') } + -- For each AT argument compute the position of the corresponding class + -- parameter in the class head. This will later serve as a permutation + -- vector when checking the validity of instance declarations. + setTyThingPoss [ATyCon tycon] atTyVars = + let classTyVars = hsLTyVarNames tvs + poss = catMaybes + . map (`elemIndex` classTyVars) + . hsLTyVarNames + $ atTyVars + -- There will be no Nothing, as we already passed renaming + in + ATyCon (setTyConArgPoss tycon poss) + setTyThingPoss _ _ = panic "TcTyClsDecls.setTyThingPoss" tcTyClDecl1 calc_isrec (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) @@ -730,8 +762,10 @@ tcTyClDecl1 calc_isrec ----------------------------------- tcConDecl :: Bool -- True <=> -funbox-strict_fields - -> NewOrData -> TyCon -> [TyVar] - -> ConDecl Name -> TcM DataCon + -> NewOrData + -> TyCon -> [TyVar] + -> ConDecl Name + -> TcM DataCon tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes (ConDecl name _ ex_tvs ex_ctxt details ResTyH98) @@ -749,9 +783,10 @@ tcConDecl unbox_strict NewType tycon tc_tvs -- Newtypes ; 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 } @@ -769,9 +804,9 @@ tcConDecl unbox_strict DataType tycon tc_tvs -- Data types (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. + -- 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 @@ -1146,7 +1181,16 @@ tooFewParmsErr tc_name = ptext SLIT("Indexed type instance has too few parameters:") <+> quotes (ppr tc_name) -badBootTyIdxDeclErr = ptext SLIT("Illegal indexed type instance in hs-boot file") +badBootTyIdxDeclErr = + ptext SLIT("Illegal indexed type instance in hs-boot file") + +wrongKindOfFamily family = + ptext SLIT("Wrong category of type instance; declaration was for a") <+> + kindOfFamily + where + kindOfFamily | isSynTyCon family = ptext SLIT("type synonym") + | isDataTyCon family = ptext SLIT("data type") + | isNewTyCon family = ptext SLIT("newtype") emptyConDeclsErr tycon = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),