diff options
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/iface/IfaceSyn.lhs | 16 | ||||
-rw-r--r-- | compiler/iface/MkIface.lhs | 6 | ||||
-rw-r--r-- | compiler/iface/TcIface.lhs | 9 | ||||
-rw-r--r-- | compiler/typecheck/TcInstDcls.lhs | 26 | ||||
-rw-r--r-- | compiler/typecheck/TcRnDriver.lhs | 10 | ||||
-rw-r--r-- | compiler/typecheck/TcTyClsDecls.lhs | 81 | ||||
-rw-r--r-- | compiler/types/Class.lhs | 10 | ||||
-rw-r--r-- | compiler/utils/Util.lhs | 7 |
8 files changed, 98 insertions, 67 deletions
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 55fcec0658..28b60c41cf 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -103,9 +103,13 @@ data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType -- Just False => ordinary polymorphic default method -- Just True => generic default method -data IfaceAT = IfaceAT IfaceDecl (Maybe [IfaceDecl]) +data IfaceAT = IfaceAT IfaceDecl (Maybe [([IfaceTvBndr], [IfaceType], IfaceType)]) -- Nothing => no default associated type instance - -- Just ds => default associated type instance from these TyCon decls + -- Just ds => default associated type instance from these templates + -- Each template is a triple of: + -- 1. TyVars of the RHS and family arguments (including the class TVs) + -- 3. The instantiated family arguments + -- 2. The RHS of the synonym data IfaceConDecls = IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon @@ -388,7 +392,7 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, -- no wrapper (class dictionaries never have a wrapper) [dc_occ, dcww_occ] ++ -- associated types - [n | IfaceAT at mb_defs <- ats, n <- ifName at : maybe [] (map ifName) mb_defs ] ++ + [ifName at | IfaceAT at _ <- ats ] ++ -- superclass selectors [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] ++ -- operation selectors @@ -733,7 +737,11 @@ freeNamesIfContext = fnList freeNamesIfPredType freeNamesIfAT :: IfaceAT -> NameSet freeNamesIfAT (IfaceAT decl mb_defs) = freeNamesIfDecl decl &&& - maybe emptyNameSet (fnList freeNamesIfDecl) mb_defs + maybe emptyNameSet (fnList fn_at_def) mb_defs + where + fn_at_def (tvs, pat_tys, ty) = freeNamesIfTvBndrs tvs &&& + fnList freeNamesIfType pat_tys &&& + freeNamesIfType ty freeNamesIfClsSig :: IfaceClassOp -> NameSet freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index f43cbd48fc..a04ce174ad 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1339,9 +1339,13 @@ tyThingToIfaceDecl (AClass clas) = classExtraBigSig clas tycon = classTyCon clas + toIfaceAT :: ClassATItem -> IfaceAT toIfaceAT (tc, def_tcs) = IfaceAT (tyThingToIfaceDecl (ATyCon tc)) - (fmap (map (tyThingToIfaceDecl . ATyCon)) def_tcs) + (fmap (map to_if_at_def) def_tcs) + where + to_if_at_def (tvs, pat_tys, ty) + = (toIfaceTvBndrs tvs, map toIfaceType pat_tys, toIfaceType ty) toIfaceClassOp (sel_id, def_meth) = ASSERT(sel_tyvars == clas_tyvars) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 8f2906868b..deeb649cef 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -494,14 +494,17 @@ tc_iface_decl _parent ignore_prags tc_at cls (IfaceAT tc_decl mb_def_decls) = do tc <- tc_iface_tc_decl (AssocFamilyTyCon cls) tc_decl - mb_def_tcs <- traverse (mapM (tc_iface_tc_decl NoParentTyCon)) mb_def_decls + mb_def_tcs <- traverse (mapM tc_iface_at_def) mb_def_decls -- Defaults are just like associated type instances: their real parent will -- be filled in later by mkFamInstParentInfo (called by buildSynTyCon) return (tc, mb_def_tcs) tc_iface_tc_decl parent decl = do - ATyCon tc <- tc_iface_decl parent ignore_prags decl - return tc + ATyCon tc <- tc_iface_decl parent ignore_prags decl + return tc + + tc_iface_at_def (tvs, pat_tys, ty) = + bindIfaceTyVars_AT tvs $ \tvs' -> liftM2 ((,,) tvs') (mapM tcIfaceType pat_tys) (tcIfaceType ty) mk_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty] diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 78c3aa3003..d97ca84d90 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -36,7 +36,7 @@ import DataCon import Class import Var import VarEnv -import VarSet ( mkVarSet, unionVarSet, varSetElems ) +import VarSet ( mkVarSet, varSetElems ) import Pair import CoreUtils ( mkPiTypes ) import CoreUnfold ( mkDFunUnfolding ) @@ -468,20 +468,16 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) else case mb_defs of Nothing -> return (Just (tyConName fam_tc), []) Just defs -> do - defs' <- forM defs $ \def -> do - case tyConFamInst_maybe def of - Nothing -> pprPanic "tcLocalInstDecl1:not family instance TyCon" (ppr def) - Just (parent_fam_tc, fam_inst_tys) -> ASSERT(parent_fam_tc == fam_tc) do - let SynonymTyCon rhs = synTyConRhs def - iss = mkInScopeSet (tyVarsOfTypes fam_inst_tys `unionVarSet` tyVarsOfType rhs) - mini_env_subst = mkTvSubst iss mini_env - fam_inst_tys' = substTys mini_env_subst fam_inst_tys - rhs' = substTy mini_env_subst rhs - rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) fam_inst_tys' - buildSynTyCon rep_tc_name (varSetElems (tyVarsOfType rhs')) - (SynonymTyCon rhs') - (tyConKind def) - NoParentTyCon (Just (fam_tc, fam_inst_tys')) + defs' <- forM defs $ \(tvs, pat_tys, rhs) -> do + let mini_env_subst = mkTvSubst (mkInScopeSet (mkVarSet tvs)) mini_env + tvs' = varSetElems (tyVarsOfType rhs') + pat_tys' = substTys mini_env_subst pat_tys + rhs' = substTy mini_env_subst rhs + rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys' + buildSynTyCon rep_tc_name tvs' + (SynonymTyCon rhs') + (mkArrowKinds (map tyVarKind tvs') (typeKind rhs')) + NoParentTyCon (Just (fam_tc, pat_tys')) return (Nothing, defs') ; let (omitted, idx_tycons1) = unzip missing_at_stuff diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 503195924e..e95ccecca3 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -719,7 +719,13 @@ checkBootDecl (AClass c1) (AClass c2) eqAT (tc1, def_ats1) (tc2, def_ats2) = checkBootTyCon tc1 tc2 && - def_ats1 == def_ats2 + eqMaybeBy (eqListBy eqATDef) def_ats1 def_ats2 + + eqATDef (tvs1, ty_pats1, ty1) (tvs2, ty_pats2, ty2) + = eqListBy same_kind tvs1 tvs2 && + eqListBy (eqTypeX env) ty_pats1 ty_pats2 && + eqTypeX env ty1 ty2 + where env = rnBndrs2 env0 tvs1 tvs2 eqFD (as1,bs1) (as2,bs2) = eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && @@ -734,7 +740,7 @@ checkBootDecl (AClass c1) (AClass c2) || -- Above tests for an "abstract" class eqListBy (eqPredX env) sc_theta1 sc_theta2 && eqListBy eqSig op_stuff1 op_stuff2 && - eqListBy eqAT ats1 ats2) + eqListBy eqAT ats1 ats2) checkBootDecl (ADataCon dc1) (ADataCon _) = pprPanic "checkBootDecl" (ppr dc1) diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 635584a193..e613715eb8 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -8,7 +8,7 @@ TcTyClsDecls: Typecheck type and class declarations \begin{code} module TcTyClsDecls ( tcTyAndClassDecls, kcDataDecl, tcConDecls, mkRecSelBinds, - tcTopFamInstDecl, tcAssocDecl, tcDefaultAssocDecl, + tcTopFamInstDecl, tcAssocDecl, checkValidTyCon, dataDeclChecks ) where @@ -583,12 +583,7 @@ tcClassATs clas clas_tvs ats at_defs = do dat <- case lookupNameEnv at_defs_map (tyConName fam_tc) of Nothing -> return Nothing Just def_decls -> do - liftM Just $ mapM (\def_decl -> do - -- NB: We have to explicitly extend the environment here because - -- tcDefaultAssocDecl will pull on the fam_tc when checking the default instance, - -- and the the version of the fam_tc currently present in the environment is _|_ - tcExtendGlobalEnv [ATyCon fam_tc] $ - tcDefaultAssocDecl clas_tvs def_decl) def_decls + liftM Just $ mapM (tcDefaultAssocDecl fam_tc clas_tvs) def_decls return (fam_tc, dat) \end{code} @@ -708,35 +703,16 @@ tcFamInstDecl1 :: TyCon -> TyClDecl Name -> TcM TyCon -- "type instance" tcFamInstDecl1 fam_tc (decl@TySynonym {}) - = kcIdxTyPats fam_tc decl $ \k_tvs k_typats resKind -> - do { -- check that the family declaration is for a synonym - checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) - - ; -- (1) kind check the right-hand side of the type equation - ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk) - -- ToDo: the ExpKind could be better - - -- we need the exact same number of type parameters as the family - -- declaration - ; let famArity = tyConArity fam_tc - ; checkTc (length k_typats == famArity) $ - wrongNumberOfParmsErr famArity + = do { -- (1) do the work of verifying the synonym + ; (t_tvs, t_typats, t_rhs) <- tcFamSynInstDecl1 fam_tc decl - -- (2) type check type equation - ; tcTyVarBndrs k_tvs $ \t_tvs -> do -- turn kinded into proper tyvars - { t_typats <- mapM tcHsKindedType k_typats - ; t_rhs <- tcHsKindedType k_rhs - - -- (3) check the well-formedness of the instance - ; checkValidTypeInst t_typats t_rhs - - -- (4) construct representation tycon + -- (2) construct representation tycon ; rep_tc_name <- newFamInstTyConName (tcdLName decl) t_typats ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) (typeKind t_rhs) NoParentTyCon (Just (fam_tc, t_typats)) - }} + } -- "newtype instance" and "data instance" tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data @@ -796,6 +772,34 @@ tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data _ -> True tcFamInstDecl1 _ d = pprPanic "tcFamInstDecl1" (ppr d) + + +tcFamSynInstDecl1 :: TyCon -> TyClDecl Name -> TcM ([TyVar], [Type], Type) +tcFamSynInstDecl1 fam_tc (decl@TySynonym {}) + = kcIdxTyPats fam_tc decl $ \k_tvs k_typats resKind -> + do { -- check that the family declaration is for a synonym + checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) + + ; -- (1) kind check the right-hand side of the type equation + ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk) + -- ToDo: the ExpKind could be better + + -- we need the exact same number of type parameters as the family + -- declaration + ; let famArity = tyConArity fam_tc + ; checkTc (length k_typats == famArity) $ + wrongNumberOfParmsErr famArity + + -- (2) type check type equation + ; tcTyVarBndrs k_tvs $ \t_tvs -> do -- turn kinded into proper tyvars + { t_typats <- mapM tcHsKindedType k_typats + ; t_rhs <- tcHsKindedType k_rhs + + -- (3) check the well-formedness of the instance + ; checkValidTypeInst t_typats t_rhs + + ; return (t_tvs, t_typats, t_rhs) }} +tcFamSynInstDecl1 _ decl = pprPanic "tcFamSynInstDecl1" (ppr decl) \end{code} %************************************************************************ @@ -836,21 +840,22 @@ tcAssocDecl clas mini_env (L loc decl) = return () -- Allow non-type-variable instantiation -- See Note [Associated type instances] -tcDefaultAssocDecl :: [TyVar] -- ^ TyVars of associated type's class - -> LTyClDecl Name -- ^ RHS - -> TcM TyCon -tcDefaultAssocDecl clas_tvs (L loc decl) +tcDefaultAssocDecl :: TyCon -- ^ Family TyCon + -> [TyVar] -- ^ TyVars of associated type's class + -> LTyClDecl Name -- ^ RHS + -> TcM ([TyVar], [Type], Type) -- ^ Type checked RHS and free TyVars +tcDefaultAssocDecl fam_tc clas_tvs (L loc decl) = setSrcSpan loc $ tcAddDeclCtxt decl $ - do { at_tc <- tcFamInstDecl NotTopLevel decl - ; let Just (_fam_tc, at_tys) = tyConFamInst_maybe at_tc - + do { (at_tvs, at_tys, at_rhs) <- tcFamSynInstDecl1 fam_tc decl + ; checkValidType (TySynCtxt (tyConName fam_tc)) at_rhs + -- See Note [Checking consistent instantiation] -- We only want to check this on the *class* TyVars, -- not the *family* TyVars (there may be more of these) ; zipWithM_ check_arg clas_tvs at_tys - ; return at_tc } + ; return (at_tvs, at_tys, at_rhs) } where check_arg fam_tc_tv at_ty = checkTc (mkTyVarTy fam_tc_tv `eqType` at_ty) diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs index ba20555494..a64d879f88 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -24,7 +24,7 @@ module Class ( #include "HsVersions.h" import {-# SOURCE #-} TyCon ( TyCon ) -import {-# SOURCE #-} TypeRep ( PredType ) +import {-# SOURCE #-} TypeRep ( Type, PredType ) import Var import Name @@ -85,9 +85,13 @@ data DefMeth = NoDefMeth -- No default method | GenDefMeth Name -- A generic default method deriving Eq -type ClassATItem = (TyCon, Maybe [TyCon]) +type ClassATItem = (TyCon, Maybe [([TyVar], [Type], Type)]) -- Nothing => No default associated type - -- Just tcs => Default associated types from these templates + -- Just tcs => Default associated types from these templates. + -- Each template is a triple of: + -- 1. TyVars of the RHS and family arguments (including the class TVs) + -- 3. The instantiated family arguments + -- 2. The RHS of the synonym -- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in -- the `DefMeth` constructor of the `DefMeth`. diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index c5f1c0c2ed..6a15896fcb 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -44,7 +44,7 @@ module Util ( sortLe, sortWith, minWith, on, -- * Comparisons - isEqual, eqListBy, + isEqual, eqListBy, eqMaybeBy, thenCmp, cmpList, removeSpaces, @@ -677,6 +677,11 @@ eqListBy _ [] [] = True eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys eqListBy _ _ _ = False +eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool +eqMaybeBy _ Nothing Nothing = True +eqMaybeBy eq (Just x) (Just y) = eq x y +eqMaybeBy _ _ _ = False + cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering -- `cmpList' uses a user-specified comparer |