X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=8ff44ad05915aa7b0589a8e96c9f1d28897fe321;hb=ba16e1bfde86cc6d8fafa9be8a33b3b6172f262f;hp=203ffe4bffc18c8df2621ea6992c006a37e5e660;hpb=24f3ffdaa0ffd164616969080c3e6400f04980dd;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 203ffe4..8ff44ad 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -6,13 +6,6 @@ TcInstDecls: Typechecking instance declarations \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where import HsSyn @@ -38,6 +31,7 @@ import TypeRep import DataCon import Class import Var +import Id import MkId import Name import NameSet @@ -94,9 +88,9 @@ $tau_iop$ is the tau type for this instance of a class method \item $alpha$ is the class variable \item -$LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$ +$LIE_cop' = LIE_cop [X gammas_bar \/ alpha, fresh betas_bar]$ \item -$tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$ +$tau_cop' = tau_cop [X gammas_bar \/ alpha, fresh betas_bar]$ \end{enumerate} ToDo: Update the list above with names actually in the code. @@ -104,7 +98,7 @@ ToDo: Update the list above with names actually in the code. \begin{enumerate} \item First, make the LIEs for the class and instance contexts, which means -instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC', +instantiate $thetaC [X inst_tyvars \/ alpha ]$, yielding LIElistC' and LIEC', and make LIElistI and LIEI. \item Then process each method in turn. @@ -143,7 +137,7 @@ tcInstDecls1 -- Deal with both source-code and imported instance decls -> [LInstDecl Name] -- Source code instance decls -> [LDerivDecl Name] -- Source code stand-alone deriving decls -> TcM (TcGblEnv, -- The full inst env - [InstInfo], -- Source-code instance decls to process; + [InstInfo Name], -- Source-code instance decls to process; -- contains all dfuns for this module HsValBinds Name) -- Supporting bindings for derived instances @@ -155,13 +149,12 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- (1) Do class and family instance declarations ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls } - ; local_info_tycons <- mapM tcLocalInstDecl1 inst_decls - ; idx_tycons <- mapM tcIdxTyInstDeclTL idxty_decls + ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls + ; idx_tycons <- mapAndRecoverM tcIdxTyInstDeclTL idxty_decls - ; let { (local_infos, - at_tycons) = unzip local_info_tycons - ; local_info = concat local_infos - ; at_idx_tycon = concat at_tycons ++ catMaybes idx_tycons + ; let { (local_info, + at_tycons_s) = unzip local_info_tycons + ; at_idx_tycon = concat at_tycons_s ++ idx_tycons ; clas_decls = filter (isClassDecl.unLoc) tycl_decls ; implicit_things = concatMap implicitTyThings at_idx_tycon } @@ -187,6 +180,9 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- decl, so it needs to know about all the instances possible -- NB: class instance declarations can contain derivings as -- part of associated data type declarations + failIfErrsM -- If the addInsts stuff gave any errors, don't + -- try the deriving stuff, becuase that may give + -- more errors still ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls deriv_decls ; addInsts deriv_inst_info $ do { @@ -207,18 +203,18 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls addErr $ assocInClassErr (tcdName decl) ; return tything } - isAssocFamily (Just (ATyCon tycon)) = + isAssocFamily (ATyCon tycon) = case tyConFamInst_maybe tycon of Nothing -> panic "isAssocFamily: no family?!?" Just (fam, _) -> isTyConAssoc fam - isAssocFamily (Just _ ) = panic "isAssocFamily: no tycon?!?" - isAssocFamily Nothing = False + isAssocFamily _ = panic "isAssocFamily: no tycon?!?" +assocInClassErr :: Name -> SDoc assocInClassErr name = ptext (sLit "Associated type") <+> quotes (ppr name) <+> ptext (sLit "must be inside a class instance") -addInsts :: [InstInfo] -> TcM a -> TcM a +addInsts :: [InstInfo Name] -> TcM a -> TcM a addInsts infos thing_inside = tcExtendLocalInstEnv (map iSpec infos) thing_inside @@ -233,15 +229,13 @@ addFamInsts tycons thing_inside \begin{code} tcLocalInstDecl1 :: LInstDecl Name - -> TcM ([InstInfo], [TyThing]) -- [] if there was an error + -> TcM (InstInfo Name, [TyThing]) -- A source-file instance declaration -- Type-check all the stuff before the "where" -- -- We check for respectable instance type, and context -tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) - = -- Prime error recovery, set source location - recoverM (return ([], [])) $ - setSrcSpan loc $ +tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) + = setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ do { is_boot <- tcIsHsBoot @@ -250,27 +244,30 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) ; (tyvars, theta, tau) <- tcHsInstHead poly_ty - -- Next, process any associated types. - ; idx_tycons <- mapM tcFamInstDecl ats - -- Now, check the validity of the instance. ; (clas, inst_tys) <- checkValidInstHead tau ; checkValidInstance tyvars theta clas inst_tys - ; checkValidAndMissingATs clas (tyvars, inst_tys) - (zip ats idx_tycons) + + -- Next, process any associated types. + ; idx_tycons <- recoverM (return []) $ + do { idx_tycons <- checkNoErrs $ mapAndRecoverM tcFamInstDecl ats + ; checkValidAndMissingATs clas (tyvars, inst_tys) + (zip ats idx_tycons) + ; return idx_tycons } -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) - ; dfun_name <- newDFunName clas inst_tys loc + ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty) + -- Dfun location is that of instance *header* ; overlap_flag <- getOverlapFlag ; let (eq_theta,dict_theta) = partition isEqPred theta theta' = eq_theta ++ dict_theta dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys ispec = mkLocalInstance dfun overlap_flag - ; return ([InstInfo { iSpec = ispec, - iBinds = VanillaInst binds uprags }], - catMaybes idx_tycons) + ; return (InstInfo { iSpec = ispec, + iBinds = VanillaInst binds uprags }, + idx_tycons) } where -- We pass in the source form and the type checked form of the ATs. We @@ -279,7 +276,7 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) checkValidAndMissingATs :: Class -> ([TyVar], [TcType]) -- instance types -> [(LTyClDecl Name, -- source form of AT - Maybe TyThing)] -- Core form of AT + TyThing)] -- Core form of AT -> TcM () checkValidAndMissingATs clas inst_tys ats = do { -- Issue a warning for each class AT that is not defined in this @@ -297,9 +294,7 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) ; mapM_ (checkIndexes clas inst_tys) ats } - checkIndexes _ _ (hsAT, Nothing) = - return () -- skip, we already had an error here - checkIndexes clas inst_tys (hsAT, Just (ATyCon tycon)) = + checkIndexes clas inst_tys (hsAT, ATyCon tycon) = -- !!!TODO: check that this does the Right Thing for indexed synonyms, too! checkIndexes' clas inst_tys hsAT (tyConTyVars tycon, @@ -374,7 +369,7 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) %************************************************************************ \begin{code} -tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo] +tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name] -> TcM (LHsBinds Id, TcLclEnv) -- (a) From each class declaration, -- generate any default-method bindings @@ -460,7 +455,7 @@ is the @dfun_theta@ below. \begin{code} -tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id) +tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) -- Returns a binding for the dfun ------------------------ @@ -491,7 +486,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived }) -- inst_head_ty is a PredType ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty - (class_tyvars, sc_theta, _, op_items) = classBigSig cls + (class_tyvars, sc_theta, _, _) = classBigSig cls cls_tycon = classTyCon cls sc_theta' = substTheta (zipOpenTvSubst class_tyvars cls_inst_tys) sc_theta @@ -585,7 +580,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) dfun_id = instanceDFunId ispec rigid_info = InstSkol inst_ty = idType dfun_id - loc = srcLocSpan (getSrcLoc dfun_id) + loc = getSrcSpan dfun_id in -- Prime error recovery recoverM (return emptyLHsBinds) $ @@ -696,6 +691,10 @@ mkMetaCoVars = mapM eqPredToCoVar eqPredToCoVar (EqPred ty1 ty2) = newMetaCoVar ty1 ty2 eqPredToCoVar _ = panic "TcInstDcls.mkMetaCoVars" +tcMethods :: InstOrigin -> Class -> [TcTyVar] -> TcThetaType -> [TcType] + -> Inst -> [Inst] -> [(Id, DefMeth)] -> LHsBindsLR Name Name + -> [LSig Name] + -> TcM ([Id], Bag (LHsBind Id)) tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' this_dict extra_insts op_items monobinds uprags = do -- Check that all the method bindings come from this class @@ -743,7 +742,7 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' let prag_fn = mkPragFun uprags all_insts = extra_insts ++ catMaybes meth_insts - sig_fn n = Just [] -- No scoped type variables, but every method has + sig_fn _ = Just [] -- No scoped type variables, but every method has -- a type signature, in effect, so that we check -- the method has the right type tc_method_bind = tcMethodBind origin inst_tyvars' dfun_theta' this_dict @@ -853,29 +852,36 @@ simplified: only zeze2 is extracted and its body is simplified. %************************************************************************ \begin{code} +instDeclCtxt1 :: LHsType Name -> SDoc instDeclCtxt1 hs_inst_ty = inst_decl_ctxt (case unLoc hs_inst_ty of HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred HsPredTy pred -> ppr pred - other -> ppr hs_inst_ty) -- Don't expect this + _ -> ppr hs_inst_ty) -- Don't expect this +instDeclCtxt2 :: Type -> SDoc instDeclCtxt2 dfun_ty = inst_decl_ctxt (ppr (mkClassPred cls tys)) where (_,_,cls,tys) = tcSplitDFunTy dfun_ty +inst_decl_ctxt :: SDoc -> SDoc inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc +superClassCtxt :: SDoc superClassCtxt = ptext (sLit "When checking the super-classes of an instance declaration") +atInstCtxt :: Name -> SDoc atInstCtxt name = ptext (sLit "In the associated type instance for") <+> quotes (ppr name) +mustBeVarArgErr :: Type -> SDoc mustBeVarArgErr ty = sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+> ptext (sLit "must be variables") , ptext (sLit "Instead of a variable, found") <+> ppr ty ] +wrongATArgErr :: Type -> Type -> SDoc wrongATArgErr ty instTy = sep [ ptext (sLit "Type indexes must match class instance head") , ptext (sLit "Found") <+> ppr ty <+> ptext (sLit "but expected") <+>