X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=1f800d958193563968c64f5542821e64c59da96d;hp=14dcfcdcacaf49b08525bbff65063fb6cb6593b5;hb=9319fbaf14f420cbbd9e670093cc86c5f04b7800;hpb=ad307d5c2e8bc3989dfe6cd3be09cfd97d9d8258 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 14dcfcd..1f800d9 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 @@ -143,7 +136,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 @@ -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 { @@ -214,11 +210,12 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls isAssocFamily (Just _ ) = panic "isAssocFamily: no tycon?!?" isAssocFamily Nothing = False +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 +230,15 @@ addFamInsts tycons thing_inside \begin{code} tcLocalInstDecl1 :: LInstDecl Name - -> TcM ([InstInfo], [TyThing]) -- [] if there was an error + -> TcM ([InstInfo Name], [TyThing]) -- [] if there was an error -- 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)) +tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) = -- Prime error recovery, set source location recoverM (return ([], [])) $ - setSrcSpan loc $ + setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ do { is_boot <- tcIsHsBoot @@ -261,7 +258,8 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) -- 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 @@ -297,7 +295,7 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) ; mapM_ (checkIndexes clas inst_tys) ats } - checkIndexes _ _ (hsAT, Nothing) = + checkIndexes _ _ (_, Nothing) = return () -- skip, we already had an error here checkIndexes clas inst_tys (hsAT, Just (ATyCon tycon)) = -- !!!TODO: check that this does the Right Thing for indexed synonyms, too! @@ -374,7 +372,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 +458,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 +489,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 +583,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) $ @@ -626,10 +624,10 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) wanted_sc_insts = wanted_sc_eqs ++ sc_dicts given_sc_eqs = map (updateEqInstCoercion (mkGivenCo . TyVarTy . fromWantedCo "tcInstDecl2") ) wanted_sc_eqs given_sc_insts = given_sc_eqs ++ sc_dicts - avail_insts = [this_dict] ++ dfun_insts ++ given_sc_insts + avail_insts = dfun_insts ++ given_sc_insts (meth_ids, meth_binds) <- tcMethods origin clas inst_tyvars' - dfun_theta' inst_tys' avail_insts + dfun_theta' inst_tys' this_dict avail_insts op_items monobinds uprags -- Figure out bindings for the superclass context @@ -696,8 +694,12 @@ 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' - avail_insts op_items monobinds uprags = do + this_dict extra_insts op_items monobinds uprags = do -- Check that all the method bindings come from this class let sel_names = [idName sel_id | (sel_id, _) <- op_items] @@ -707,9 +709,9 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' -- Make the method bindings let - mk_method_bind = mkMethodBind origin clas inst_tys' monobinds + mk_method_id (sel_id, _) = mkMethId origin clas sel_id inst_tys' - (meth_insts, meth_infos) <- mapAndUnzipM mk_method_bind op_items + (meth_insts, meth_ids) <- mapAndUnzipM mk_method_id op_items -- And type check them -- It's really worth making meth_insts available to the tcMethodBind @@ -742,14 +744,14 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' -- looks like 'op at Int'. But they are not the same. let prag_fn = mkPragFun uprags - all_insts = avail_insts ++ catMaybes meth_insts - sig_fn n = Just [] -- No scoped type variables, but every method has + all_insts = extra_insts ++ catMaybes meth_insts + 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 inst_tyvars' dfun_theta' all_insts sig_fn prag_fn - meth_ids = [meth_id | (_,meth_id,_) <- meth_infos] + tc_method_bind = tcMethodBind origin inst_tyvars' dfun_theta' this_dict + all_insts sig_fn prag_fn monobinds - meth_binds_s <- mapM tc_method_bind meth_infos + meth_binds_s <- zipWithM tc_method_bind op_items meth_ids return (meth_ids, unionManyBags meth_binds_s) \end{code} @@ -853,29 +855,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") <+>