X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=df43f53e3b6ff3c984b7d6ae0485a67f72d774c9;hb=cb906a124e36cb5054784a5bc44eb9d099d20709;hp=14dcfcdcacaf49b08525bbff65063fb6cb6593b5;hpb=ad307d5c2e8bc3989dfe6cd3be09cfd97d9d8258;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 14dcfcd..df43f53 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
@@ -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,6 +210,7 @@ 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")
@@ -238,7 +235,7 @@ tcLocalInstDecl1 :: LInstDecl Name
         -- 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                      $
@@ -297,7 +294,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!
@@ -491,7 +488,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
 
@@ -626,10 +623,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 +693,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 +708,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 +743,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 +854,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") <+>