%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[TcClassDcl]{Typechecking class declarations}
+
+Typechecking class declarations
\begin{code}
module TcClassDcl ( tcClassSigs, tcClassDecl2,
getGenericInstances,
MethodSpec, tcMethodBind, mkMethodBind,
- tcAddDeclCtxt, badMethodErr
+ tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
) where
#include "HsVersions.h"
import HsSyn
-import RnHsSyn ( maybeGenericMatch, extractHsTyVars )
-import RnExpr ( rnLExpr )
-import RnEnv ( lookupTopBndrRn, lookupImportedName )
-import Inst ( instToId, newDictBndr, newDictBndrs, newMethod, getOverlapFlag )
-import InstEnv ( mkLocalInstance )
-import TcEnv ( tcLookupLocatedClass,
- tcExtendTyVarEnv, tcExtendIdEnv,
- InstInfo(..), pprInstInfoDetails,
- simpleInstInfoTyCon, simpleInstInfoTy,
- InstBindings(..), newDFunName
- )
-import TcBinds ( TcPragFun, tcMonoBinds, tcPrags, mkPragFun, TcSigInfo(..),
- TcSigFun, mkTcSigFun )
-import TcHsType ( tcHsKindedType, tcHsSigType )
-import TcSimplify ( tcSimplifyCheck )
-import TcUnify ( checkSigTyVars, sigCtxt )
-import TcMType ( tcSkolSigTyVars )
-import TcType ( Type, SkolemInfo(ClsSkol, InstSkol), UserTypeCtxt( GenPatCtxt ),
- TcType, TcThetaType, TcTyVar, mkTyVarTys,
- mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
- tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy,
- getClassPredTys_maybe, mkPhiTy, mkTyVarTy
- )
+import RnHsSyn
+import RnExpr
+import RnEnv
+import Inst
+import InstEnv
+import TcEnv
+import TcBinds
+import TcHsType
+import TcSimplify
+import TcUnify
+import TcMType
+import TcType
import TcRnMonad
-import Generics ( mkGenericRhs, validGenericInstanceType )
-import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
-import Class ( classTyVars, classBigSig,
- Class, ClassOpItem, DefMeth (..) )
-import TyCon ( TyCon, tyConName, tyConHasGenerics )
-import Type ( substTyWith )
-import MkId ( mkDefaultMethodId, mkDictFunId )
-import Id ( Id, idType, idName, mkUserLocal )
-import Name ( Name, NamedThing(..) )
-import NameEnv ( NameEnv, lookupNameEnv, mkNameEnv )
-import NameSet ( nameSetToList )
-import OccName ( reportIfUnused, mkDefaultMethodOcc )
-import RdrName ( RdrName, mkDerivedRdrName )
+import Generics
+import PrelInfo
+import Class
+import TyCon
+import Type
+import MkId
+import Id
+import Name
+import NameEnv
+import NameSet
+import OccName
+import RdrName
import Outputable
-import PrelNames ( genericTyConNames )
+import PrelNames
import DynFlags
-import ErrUtils ( dumpIfSet_dyn )
-import Util ( count, lengthIs, isSingleton, lengthExceeds )
-import Unique ( Uniquable(..) )
-import ListSetOps ( equivClassesByUniq, minusList )
-import SrcLoc ( Located(..), srcSpanStart, unLoc, noLoc )
-import Maybes ( seqMaybe, isJust, mapCatMaybes )
-import List ( partition )
-import BasicTypes ( RecFlag(..), Boxity(..) )
+import ErrUtils
+import Util
+import Unique
+import ListSetOps
+import SrcLoc
+import Maybes
+import List
+import BasicTypes
import Bag
import FastString
\end{code}
-
Dictionary handling
~~~~~~~~~~~~~~~~~~~
Every class implicitly declares a new data type, corresponding to dictionaries
-- Check the context
{ dict_binds <- tcSimplifyCheck
- (ptext SLIT("class") <+> ppr clas)
+ loc
tyvars
[this_dict]
insts_needed
let
[(_, Just sig, local_meth_id)] = mono_bind_infos
+ loc = sig_loc sig
in
addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
- newDictBndrs (sig_loc sig) (sig_theta sig) `thenM` \ meth_dicts ->
+ newDictBndrs loc (sig_theta sig) `thenM` \ meth_dicts ->
let
meth_tvs = sig_tvs sig
all_tyvars = meth_tvs ++ inst_tyvars
all_insts = avail_insts ++ meth_dicts
in
tcSimplifyCheck
- (ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
- all_tyvars all_insts meth_lie `thenM` \ lie_binds ->
+ loc all_tyvars all_insts meth_lie `thenM` \ lie_binds ->
checkSigTyVars all_tyvars `thenM_`
getSrcSpanM `thenM` \ loc ->
let
real_tau = mkPhiTy (tail preds) tau
- meth_id = mkUserLocal (getOccName sel_id) uniq real_tau
- (srcSpanStart loc) --TODO
+ meth_id = mkUserLocal (getOccName sel_id) uniq real_tau loc
in
returnM (Nothing, meth_id)
other -> Nothing
other -> Nothing
-isInstDecl (SigOrigin (InstSkol _)) = True
-isInstDecl (SigOrigin (ClsSkol _)) = False
+isInstDecl (SigOrigin InstSkol) = True
+isInstDecl (SigOrigin (ClsSkol _)) = False
\end{code}
-- f {| a+b |} ... = ...
-- f {| x+y |} ... = ...
-- Then at this point we'll have an InstInfo for each
+ --
+ -- The class should be unary, which is why simpleInstInfoTyCon should be ok
let
tc_inst_infos :: [(TyCon, InstInfo)]
tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
-- Make the dictionary function.
getSrcSpanM `thenM` \ span ->
getOverlapFlag `thenM` \ overlap_flag ->
- newDFunName clas [inst_ty] (srcSpanStart span) `thenM` \ dfun_name ->
+ newDFunName clas [inst_ty] span `thenM` \ dfun_name ->
let
inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
tcAddDeclCtxt decl thing_inside
= addErrCtxt ctxt thing_inside
where
- thing = case decl of
- ClassDecl {} -> "class"
- TySynonym {} -> "type synonym"
- TyFunction {} -> "type function signature"
- TyData {tcdND = NewType} -> "newtype" ++ maybeSig
- TyData {tcdND = DataType} -> "data type" ++ maybeSig
+ thing | isClassDecl decl = "class"
+ | isTypeDecl decl = "type synonym" ++ maybeInst
+ | isDataDecl decl = if tcdND decl == NewType
+ then "newtype" ++ maybeInst
+ else "data type" ++ maybeInst
+ | isFamilyDecl decl = "family"
- maybeSig | isKindSigDecl decl = " signature"
- | otherwise = ""
+ maybeInst | isFamInstDecl decl = " family"
+ | otherwise = ""
ctxt = hsep [ptext SLIT("In the"), text thing,
ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
= hsep [ptext SLIT("Class"), quotes (ppr clas),
ptext SLIT("does not have a method"), quotes (ppr op)]
+badATErr clas at
+ = hsep [ptext SLIT("Class"), quotes (ppr clas),
+ ptext SLIT("does not have an associated type"), quotes (ppr at)]
+
omittedMethodWarn sel_id
= ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
+omittedATWarn at
+ = ptext SLIT("No explicit AT declaration for") <+> quotes (ppr at)
+
badGenericInstance sel_id because
= sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
because]
notSimple inst_tys
= vcat [ptext SLIT("because the instance type(s)"),
nest 2 (ppr inst_tys),
- ptext SLIT("is not a simple type of form (T a b c)")]
+ ptext SLIT("is not a simple type of form (T a1 ... an)")]
notGeneric tycon
= vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+>
projects / ghc-hetmet.git / blobdiff