X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=1f800d958193563968c64f5542821e64c59da96d;hp=a2d824289f7423c994ea85bf4593c6c206e06bee;hb=9319fbaf14f420cbbd9e670093cc86c5f04b7800;hpb=1c05d4fbb6ee7ab68470d0aa79d74a3a4f0d8383 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index a2d8242..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 @@ -217,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 @@ -236,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 @@ -264,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 @@ -300,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! @@ -377,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 @@ -463,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 ------------------------ @@ -494,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 @@ -588,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) $ @@ -699,6 +694,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 @@ -746,7 +745,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 @@ -856,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") <+>