projects
/
ghc-hetmet.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
d3355c0
)
Fix warnings in TcInstDcls
author
Ian Lynagh
<igloo@earth.li>
Fri, 6 Jun 2008 20:05:34 +0000
(20:05 +0000)
committer
Ian Lynagh
<igloo@earth.li>
Fri, 6 Jun 2008 20:05:34 +0000
(20:05 +0000)
compiler/typecheck/TcInstDcls.lhs
patch
|
blob
|
history
diff --git
a/compiler/typecheck/TcInstDcls.lhs
b/compiler/typecheck/TcInstDcls.lhs
index
a2d8242
..
df43f53
100644
(file)
--- a/
compiler/typecheck/TcInstDcls.lhs
+++ b/
compiler/typecheck/TcInstDcls.lhs
@@
-6,13
+6,6
@@
TcInstDecls: Typechecking instance declarations
\begin{code}
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
module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
import HsSyn
@@
-217,6
+210,7
@@
tcInstDecls1 tycl_decls inst_decls deriv_decls
isAssocFamily (Just _ ) = panic "isAssocFamily: no tycon?!?"
isAssocFamily Nothing = False
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")
assocInClassErr name =
ptext (sLit "Associated type") <+> quotes (ppr name) <+>
ptext (sLit "must be inside a class instance")
@@
-241,7
+235,7
@@
tcLocalInstDecl1 :: LInstDecl Name
-- Type-check all the stuff before the "where"
--
-- We check for respectable instance type, and context
-- 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 $
= -- Prime error recovery, set source location
recoverM (return ([], [])) $
setSrcSpan loc $
@@
-300,7
+294,7
@@
tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
; mapM_ (checkIndexes clas inst_tys) 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!
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!
@@
-494,7
+488,7
@@
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived })
-- inst_head_ty is a PredType
; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
-- 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
cls_tycon = classTyCon cls
sc_theta' = substTheta (zipOpenTvSubst class_tyvars cls_inst_tys) sc_theta
@@
-699,6
+693,10
@@
mkMetaCoVars = mapM eqPredToCoVar
eqPredToCoVar (EqPred ty1 ty2) = newMetaCoVar ty1 ty2
eqPredToCoVar _ = panic "TcInstDcls.mkMetaCoVars"
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
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
+744,7
@@
tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
let
prag_fn = mkPragFun uprags
all_insts = extra_insts ++ catMaybes meth_insts
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
-- 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
+854,36
@@
simplified: only zeze2 is extracted and its body is simplified.
%************************************************************************
\begin{code}
%************************************************************************
\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
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
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
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")
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)
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
]
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") <+>
wrongATArgErr ty instTy =
sep [ ptext (sLit "Type indexes must match class instance head")
, ptext (sLit "Found") <+> ppr ty <+> ptext (sLit "but expected") <+>