X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=3c25a7fa2712627578380bda0c7d48ef5c3c81a2;hp=278ffe8b5d3f25e44d26e2f85ac4ed6fe89beb65;hb=138b885a335734039daf7debb0a7dfc3dc947c00;hpb=d5c4754dcb857be7b9f4dbf6482e6050a9cd0991 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 278ffe8..3c25a7f 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -25,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, @@ -66,11 +67,12 @@ import Monad ( unless ) import Unify ( tcMatchTys, tcMatchTyX ) import Util ( zipLazy, isSingleton, notNull, sortLe ) import List ( partition, elemIndex ) -import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan ) +import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan, + srcSpanStart ) import ListSetOps ( equivClasses, minusList ) import Digraph ( SCC(..) ) import DynFlags ( DynFlag( Opt_GlasgowExts, Opt_Generics, - Opt_UnboxStrictFields ) ) + Opt_UnboxStrictFields, Opt_IndexedTypes ) ) \end{code} @@ -213,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] @@ -249,16 +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, Maybe TyThing) -- 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, Nothing)) $ + recoverM (returnM Nothing) $ setSrcSpan loc $ tcAddDeclCtxt decl $ - do { -- indexed data types require -fglasgow-exts and can't be in an + 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 @@ -267,8 +276,7 @@ tcIdxTyInstDecl (L loc decl) ; tcIdxTyInstDecl1 decl } -tcIdxTyInstDecl1 :: TyClDecl Name - -> TcM (Maybe InstInfo, Maybe TyThing) -- Nothing if error +tcIdxTyInstDecl1 :: TyClDecl Name -> TcM (Maybe TyThing) -- Nothing if error tcIdxTyInstDecl1 (decl@TySynonym {}) = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> @@ -284,9 +292,8 @@ 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, Nothing) -- !!!TODO: need InstInfo for eq axioms + ; return Nothing -- !!!TODO: need TyThing for indexed synonym }} tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, @@ -319,6 +326,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ; 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)) @@ -326,10 +334,9 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ; tc_rhs <- case new_or_data of DataType -> return (mkDataTyConRhs data_cons) - NewType -> - ASSERT( isSingleton data_cons ) - mkNewTyConRhs tc_name tycon (head data_cons) - ; buildAlgTyCon tc_name t_tvs stupid_theta tc_rhs Recursive + 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 @@ -339,7 +346,7 @@ tcIdxTyInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, }) -- construct result - ; return (Nothing, Just (ATyCon tycon)) + ; return $ Just (ATyCon tycon) }} where h98_syntax = case cons of -- All constructors have same shape @@ -361,10 +368,8 @@ kcIdxTyPats :: TyClDecl Name -> TcM a kcIdxTyPats decl thing_inside = kcHsTyVars (tcdTyVars decl) $ \tvs -> - do { tc_ty_thing <- tcLookupLocated (tcdLName decl) - ; let { family = case tc_ty_thing of - AGlobal (ATyCon family) -> family - ; (kinds, resKind) = splitKindFunTys (tyConKind family) + 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 @@ -625,7 +630,7 @@ tcTyClDecl1 _calc_isrec (TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind}) = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "type family: " <+> ppr 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 @@ -643,7 +648,7 @@ tcTyClDecl1 _calc_isrec ; 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 @@ -737,6 +742,9 @@ 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 @@ -746,8 +754,7 @@ tcTyClDecl1 calc_isrec -- There will be no Nothing, as we already passed renaming in ATyCon (setTyConArgPoss tycon poss) - setTyThingPoss _ _ = panic "setTyThingPoss" - + setTyThingPoss _ _ = panic "TcTyClsDecls.setTyThingPoss" tcTyClDecl1 calc_isrec (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})