\section[TcClassDcl]{Typechecking class declarations}
\begin{code}
-module TcClassDcl ( tcClassDecl1, tcClassDecls2,
- MethodSpec, tcMethodBind, mkMethodBind, badMethodErr
+module TcClassDcl ( tcClassSigs, tcClassDecl2,
+ getGenericInstances,
+ MethodSpec, tcMethodBind, mkMethodBind,
+ tcAddDeclCtxt, badMethodErr
) where
#include "HsVersions.h"
-import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..),
- HsExpr(..), HsLit(..), Pat(WildPat),
+import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..), HsType(..),
+ HsExpr(..), HsLit(..), Pat(WildPat), HsTyVarBndr(..),
mkSimpleMatch, andMonoBinds, andMonoBindList,
- isClassOpSig, isPragSig,
- placeHolderType
+ isPragSig, placeHolderType, mkHsForAllTy
)
-import BasicTypes ( RecFlag(..) )
+import BasicTypes ( RecFlag(..), NewOrData(..) )
import RnHsSyn ( RenamedTyClDecl, RenamedSig,
RenamedClassOpSig, RenamedMonoBinds,
- maybeGenericMatch
+ maybeGenericMatch, extractHsTyVars
)
-import RnEnv ( lookupSysName )
+import RnExpr ( rnExpr )
+import RnEnv ( lookupTopBndrRn, lookupImportedName )
import TcHsSyn ( TcMonoBinds )
import Inst ( Inst, InstOrigin(..), instToId, newDicts, newMethod )
-import TcEnv ( TyThingDetails(..),
- tcLookupClass, tcExtendLocalValEnv2,
- tcExtendTyVarEnv2, tcExtendTyVarEnv
+import TcEnv ( tcLookupClass, tcExtendLocalValEnv2, tcExtendTyVarEnv2,
+ InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy,
+ InstBindings(..), newDFunName
)
-import TcTyDecls ( tcMkDataCon )
import TcBinds ( tcMonoBinds, tcSpecSigs )
-import TcMonoType ( TcSigInfo(..), tcHsType, tcHsTheta, mkTcSig )
+import TcHsType ( TcSigInfo(..), mkTcSig, tcHsKindedType, tcHsSigType )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import TcUnify ( checkSigTyVars, sigCtxt )
-import TcMType ( tcInstTyVars )
+import TcMType ( tcInstTyVars, UserTypeCtxt( GenPatCtxt ) )
import TcType ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar,
- mkTyVarTys, mkPredTys, mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
+ mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy,
- getClassPredTys_maybe, mkPhiTy
+ getClassPredTys_maybe, mkPhiTy, mkTyVarTy
)
import TcRnMonad
-import Generics ( mkGenericRhs )
+import Generics ( mkGenericRhs, validGenericInstanceType )
import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
-import Class ( classTyVars, classBigSig, classTyCon,
+import Class ( classTyVars, classBigSig,
Class, ClassOpItem, DefMeth (..) )
-import TyCon ( tyConGenInfo )
+import TyCon ( TyCon, tyConName, tyConHasGenerics )
import Subst ( substTyWith )
-import MkId ( mkDictSelId, mkDefaultMethodId )
+import MkId ( mkDefaultMethodId, mkDictFunId )
import Id ( Id, idType, idName, mkUserLocal, setInlinePragma )
import Name ( Name, NamedThing(..) )
import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
-import NameSet ( emptyNameSet, unitNameSet )
-import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, reportIfUnused )
+import NameSet ( emptyNameSet, unitNameSet, nameSetToList )
+import OccName ( reportIfUnused, mkDefaultMethodOcc )
+import RdrName ( RdrName, mkDerivedRdrName )
import Outputable
import Var ( TyVar )
+import PrelNames ( genericTyConNames )
import CmdLineOpts
import UnicodeUtil ( stringToUtf8 )
-import ErrUtils ( dumpIfSet )
-import Util ( count, lengthIs, isSingleton )
-import Maybes ( seqMaybe )
-import Maybe ( isJust )
+import ErrUtils ( dumpIfSet, dumpIfSet_dyn )
+import Util ( count, lengthIs, isSingleton, lengthExceeds )
+import Unique ( Uniquable(..) )
+import ListSetOps ( equivClassesByUniq, minusList )
+import SrcLoc ( SrcLoc )
+import Maybes ( seqMaybe, isJust, mapCatMaybes )
+import List ( partition )
import FastString
\end{code}
%************************************************************************
%* *
-\subsection{Type checking}
+ Type-checking the class op signatures
%* *
%************************************************************************
\begin{code}
+tcClassSigs :: Name -- Name of the class
+ -> [RenamedClassOpSig]
+ -> RenamedMonoBinds
+ -> TcM [TcMethInfo]
+
+type TcMethInfo = (Name, DefMeth, Type) -- A temporary intermediate, to communicate
+ -- between tcClassSigs and buildClass
+tcClassSigs clas sigs def_methods
+ = do { dm_env <- checkDefaultBinds clas op_names def_methods
+ ; mappM (tcClassSig dm_env) op_sigs }
+ where
+ op_sigs = [sig | sig@(Sig n _ _) <- sigs]
+ op_names = [n | sig@(Sig n _ _) <- op_sigs]
-tcClassDecl1 :: RenamedTyClDecl -> TcM (Name, TyThingDetails)
-tcClassDecl1 (ClassDecl {tcdCtxt = context, tcdName = class_name,
- tcdTyVars = tyvar_names, tcdFDs = fundeps,
- tcdSigs = class_sigs, tcdMeths = def_methods,
- tcdLoc = src_loc})
- = -- LOOK THINGS UP IN THE ENVIRONMENT
- tcLookupClass class_name `thenM` \ clas ->
- let
- tyvars = classTyVars clas
- op_sigs = filter isClassOpSig class_sigs
- op_names = [n | ClassOpSig n _ _ _ <- op_sigs]
- in
- tcExtendTyVarEnv tyvars $
-
- checkDefaultBinds clas op_names def_methods `thenM` \ mb_dm_env ->
-
- -- CHECK THE CONTEXT
- -- The renamer has already checked that the context mentions
- -- only the type variable of the class decl.
- -- Context is already kind-checked
- tcHsTheta context `thenM` \ sc_theta ->
-
- -- CHECK THE CLASS SIGNATURES,
- mappM (tcClassSig clas tyvars mb_dm_env) op_sigs `thenM` \ sig_stuff ->
-
- -- MAKE THE CLASS DETAILS
- lookupSysName class_name mkClassTyConOcc `thenM` \ tycon_name ->
- lookupSysName class_name mkClassDataConOcc `thenM` \ datacon_name ->
- mapM (lookupSysName class_name . mkSuperDictSelOcc)
- [1..length context] `thenM` \ sc_sel_names ->
- -- We number off the superclass selectors, 1, 2, 3 etc so that we
- -- can construct names for the selectors. Thus
- -- class (C a, C b) => D a b where ...
- -- gives superclass selectors
- -- D_sc1, D_sc2
- -- (We used to call them D_C, but now we can have two different
- -- superclasses both called C!)
- let
- (op_tys, op_items) = unzip sig_stuff
- sc_tys = mkPredTys sc_theta
- dict_component_tys = sc_tys ++ op_tys
- sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names]
- in
- tcMkDataCon datacon_name
- [{- No strictness -}]
- [{- No labelled fields -}]
- tyvars [{-No context-}]
- [{-No existential tyvars-}] [{-Or context-}]
- dict_component_tys
- (classTyCon clas) `thenM` \ dict_con ->
-
- returnM (class_name, ClassDetails sc_theta sc_sel_ids op_items dict_con tycon_name)
-\end{code}
-
-\begin{code}
-checkDefaultBinds :: Class -> [Name] -> Maybe RenamedMonoBinds
- -> TcM (Maybe (NameEnv Bool))
- -- The returned environment says
- -- x not in env => no default method
- -- x -> True => generic default method
- -- x -> False => polymorphic default method
-
+
+checkDefaultBinds :: Name -> [Name] -> RenamedMonoBinds
+ -> TcM (NameEnv Bool)
-- Check default bindings
-- a) must be for a class op for this class
-- b) must be all generic or all non-generic
- -- and return a mapping from class-op to DefMeth info
+ -- and return a mapping from class-op to Bool
+ -- where True <=> it's a generic default method
- -- But do all this only for source binds
+checkDefaultBinds clas ops EmptyMonoBinds
+ = returnM emptyNameEnv
-checkDefaultBinds clas ops Nothing
- = returnM Nothing
+checkDefaultBinds clas ops (AndMonoBinds b1 b2)
+ = do { dm_info1 <- checkDefaultBinds clas ops b1
+ ; dm_info2 <- checkDefaultBinds clas ops b2
+ ; returnM (dm_info1 `plusNameEnv` dm_info2) }
-checkDefaultBinds clas ops (Just mbs)
- = go mbs `thenM` \ dm_env ->
- returnM (Just dm_env)
- where
- go EmptyMonoBinds = returnM emptyNameEnv
-
- go (AndMonoBinds b1 b2)
- = go b1 `thenM` \ dm_info1 ->
- go b2 `thenM` \ dm_info2 ->
- returnM (dm_info1 `plusNameEnv` dm_info2)
-
- go (FunMonoBind op _ matches loc)
- = addSrcLoc loc $
-
- -- Check that the op is from this class
- checkTc (op `elem` ops) (badMethodErr clas op) `thenM_`
+checkDefaultBinds clas ops (FunMonoBind op _ matches loc)
+ = addSrcLoc loc $ do
+ { -- Check that the op is from this class
+ checkTc (op `elem` ops) (badMethodErr clas op)
-- Check that all the defns ar generic, or none are
- checkTc (all_generic || none_generic) (mixedGenericErr op) `thenM_`
+ ; checkTc (all_generic || none_generic) (mixedGenericErr op)
- returnM (unitNameEnv op all_generic)
- where
- n_generic = count (isJust . maybeGenericMatch) matches
- none_generic = n_generic == 0
- all_generic = matches `lengthIs` n_generic
-\end{code}
+ ; returnM (unitNameEnv op all_generic)
+ }
+ where
+ n_generic = count (isJust . maybeGenericMatch) matches
+ none_generic = n_generic == 0
+ all_generic = matches `lengthIs` n_generic
-\begin{code}
-tcClassSig :: Class -- ...ditto...
- -> [TyVar] -- The class type variable, used for error check only
- -> Maybe (NameEnv Bool) -- Info about default methods;
- -- Nothing => imported class defn with no method binds
+tcClassSig :: NameEnv Bool -- Info about default methods;
-> RenamedClassOpSig
- -> TcM (Type, -- Type of the method
- ClassOpItem) -- Selector Id, default-method Id, True if explicit default binding
-
--- This warrants an explanation: we need to separate generic
--- default methods and default methods later on in the compiler
--- so we distinguish them in checkDefaultBinds, and pass this knowledge in the
--- Class.DefMeth data structure.
-
-tcClassSig clas clas_tyvars maybe_dm_env
- (ClassOpSig op_name sig_dm op_ty src_loc)
- = addSrcLoc src_loc $
-
- -- Check the type signature. NB that the envt *already has*
- -- bindings for the type variables; see comments in TcTyAndClassDcls.
- tcHsType op_ty `thenM` \ local_ty ->
-
- let
- theta = [mkClassPred clas (mkTyVarTys clas_tyvars)]
-
- -- Build the selector id and default method id
- sel_id = mkDictSelId op_name clas
- DefMeth dm_name = sig_dm
-
- dm_info = case maybe_dm_env of
- Nothing -> sig_dm
- Just dm_env -> mk_src_dm_info dm_env
-
- mk_src_dm_info dm_env = case lookupNameEnv dm_env op_name of
- Nothing -> NoDefMeth
- Just True -> GenDefMeth
- Just False -> DefMeth dm_name
- in
- returnM (local_ty, (sel_id, dm_info))
+ -> TcM TcMethInfo
+
+tcClassSig dm_env (Sig op_name op_hs_ty src_loc)
+ = addSrcLoc src_loc $ do
+ { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
+ ; let dm = case lookupNameEnv dm_env op_name of
+ Nothing -> NoDefMeth
+ Just False -> DefMeth
+ Just True -> GenDefMeth
+ ; returnM (op_name, dm, op_ty) }
\end{code}
dfoo_list
\end{verbatim}
-The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
-each local class decl.
-
-\begin{code}
-tcClassDecls2 :: [RenamedTyClDecl] -> TcM (TcMonoBinds, [Id])
-
-tcClassDecls2 decls
- = foldr combine
- (returnM (EmptyMonoBinds, []))
- [tcClassDecl2 cls_decl | cls_decl@(ClassDecl {tcdMeths = Just _}) <- decls]
- -- The 'Just' picks out source ClassDecls
- where
- combine tc1 tc2 = tc1 `thenM` \ (binds1, ids1) ->
- tc2 `thenM` \ (binds2, ids2) ->
- returnM (binds1 `AndMonoBinds` binds2,
- ids1 ++ ids2)
-\end{code}
-
-@tcClassDecl2@ generates bindings for polymorphic default methods
+@tcClassDecls2@ generates bindings for polymorphic default methods
(generic default methods have by now turned into instance declarations)
\begin{code}
-> TcM (TcMonoBinds, [Id])
tcClassDecl2 (ClassDecl {tcdName = class_name, tcdSigs = sigs,
- tcdMeths = Just default_binds, tcdLoc = src_loc})
- = -- The 'Just' picks out source ClassDecls
- recoverM (returnM (EmptyMonoBinds, [])) $
+ tcdMeths = default_binds, tcdLoc = src_loc})
+ = recoverM (returnM (EmptyMonoBinds, [])) $
addSrcLoc src_loc $
tcLookupClass class_name `thenM` \ clas ->
(tyvars, _, _, op_items) = classBigSig clas
prags = filter isPragSig sigs
tc_dm = tcDefMeth clas tyvars default_binds prags
- in
- mapAndUnzipM tc_dm op_items `thenM` \ (defm_binds, dm_ids_s) ->
-
- returnM (andMonoBindList defm_binds, concat dm_ids_s)
-
-tcDefMeth clas tyvars binds_in prags (_, NoDefMeth) = returnM (EmptyMonoBinds, [])
-tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnM (EmptyMonoBinds, [])
+ dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
-- Generate code for polymorphic default methods only
-- (Generic default methods have turned into instance decls by now.)
-- This is incompatible with Hugs, which expects a polymorphic
-- default method for every class op, regardless of whether or not
-- the programmer supplied an explicit default decl for the class.
-- (If necessary we can fix that, but we don't have a convenient Id to hand.)
-
-tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name)
- = tcInstTyVars ClsTv tyvars `thenM` \ (clas_tyvars, inst_tys, _) ->
+ in
+ mapAndUnzipM tc_dm dm_sel_ids `thenM` \ (defm_binds, dm_ids_s) ->
+ returnM (andMonoBindList defm_binds, concat dm_ids_s)
+
+tcDefMeth clas tyvars binds_in prags sel_id
+ = lookupTopBndrRn (mkDefMethRdrName sel_id) `thenM` \ dm_name ->
+ tcInstTyVars ClsTv tyvars `thenM` \ (clas_tyvars, inst_tys, _) ->
let
dm_ty = idType sel_id -- Same as dict selector!
theta = [mkClassPred clas inst_tys]
local_dm_id = mkDefaultMethodId dm_name dm_ty
xtve = tyvars `zip` clas_tyvars
+ origin = ClassDeclOrigin
in
+ mkMethodBind origin clas inst_tys
+ binds_in (sel_id, DefMeth) `thenM` \ (_, meth_info) ->
newDicts origin theta `thenM` \ [this_dict] ->
-
- mkMethodBind origin clas inst_tys binds_in op_item `thenM` \ (_, meth_info) ->
getLIE (tcMethodBind xtve clas_tyvars theta
[this_dict] prags meth_info) `thenM` \ (defm_bind, insts_needed) ->
(dict_binds `andMonoBinds` defm_bind)
in
returnM (full_bind, [local_dm_id])
- where
- origin = ClassDeclOrigin
+
+mkDefMethRdrName :: Id -> RdrName
+mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc
\end{code}
-
%************************************************************************
%* *
-- The user didn't supply a method binding,
-- so we have to make up a default binding
-- The RHS of a default method depends on the default-method info
-mkDefMethRhs origin clas inst_tys sel_id loc (DefMeth dm_name)
+mkDefMethRhs origin clas inst_tys sel_id loc DefMeth
= -- An polymorphic default method
- traceRn (text "mkDefMeth" <+> ppr dm_name) `thenM_`
+ lookupImportedName (mkDefMethRdrName sel_id) `thenM` \ dm_name ->
+ -- Might not be imported, but will be an OrigName
+ traceRn (text "mkDefMeth" <+> ppr dm_name) `thenM_`
returnM (HsVar dm_name)
mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
checkTc (isJust maybe_tycon)
(badGenericInstance sel_id (notSimple inst_tys)) `thenM_`
- checkTc (isJust (tyConGenInfo tycon))
+ checkTc (tyConHasGenerics tycon)
(badGenericInstance sel_id (notGeneric tycon)) `thenM_`
ioToTcRn (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff) `thenM_`
- returnM rhs
+
+ -- Rename it before returning it
+ rnExpr rhs `thenM` \ (rn_rhs, _) ->
+ returnM rn_rhs
where
rhs = mkGenericRhs sel_id clas_tyvar tycon
find_bind sel_name meth_name (AndMonoBinds b1 b2)
= find_bind sel_name meth_name b1 `seqMaybe` find_bind sel_name meth_name b2
find_bind sel_name meth_name other = Nothing -- Default case
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Extracting generic instance declaration from class declarations}
+%* *
+%************************************************************************
+
+@getGenericInstances@ extracts the generic instance declarations from a class
+declaration. For exmaple
+
+ class C a where
+ op :: a -> a
+
+ op{ x+y } (Inl v) = ...
+ op{ x+y } (Inr v) = ...
+ op{ x*y } (v :*: w) = ...
+ op{ 1 } Unit = ...
+
+gives rise to the instance declarations
+
+ instance C (x+y) where
+ op (Inl v) = ...
+ op (Inr v) = ...
+
+ instance C (x*y) where
+ op (v :*: w) = ...
+
+ instance C 1 where
+ op Unit = ...
+
+
+\begin{code}
+getGenericInstances :: [RenamedTyClDecl] -> TcM [InstInfo]
+getGenericInstances class_decls
+ = do { gen_inst_infos <- mappM get_generics class_decls
+ ; let { gen_inst_info = concat gen_inst_infos }
+
+ -- Return right away if there is no generic stuff
+ ; if null gen_inst_info then returnM []
+ else do
+
+ -- Otherwise print it out
+ { dflags <- getDOpts
+ ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
+ (vcat (map pprInstInfo gen_inst_info)))
+ ; returnM gen_inst_info }}
+
+get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = def_methods, tcdLoc = loc})
+ | null generic_binds
+ = returnM [] -- The comon case: no generic default methods
+
+ | otherwise -- A source class decl with generic default methods
+ = recoverM (returnM []) $
+ tcAddDeclCtxt decl $
+ tcLookupClass class_name `thenM` \ clas ->
+
+ -- Group by type, and
+ -- make an InstInfo out of each group
+ let
+ groups = groupWith andMonoBindList generic_binds
+ in
+ mappM (mkGenericInstance clas loc) groups `thenM` \ inst_infos ->
+
+ -- Check that there is only one InstInfo for each type constructor
+ -- The main way this can fail is if you write
+ -- f {| a+b |} ... = ...
+ -- f {| x+y |} ... = ...
+ -- Then at this point we'll have an InstInfo for each
+ let
+ tc_inst_infos :: [(TyCon, InstInfo)]
+ tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
+
+ bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
+ group `lengthExceeds` 1]
+ get_uniq (tc,_) = getUnique tc
+ in
+ mappM (addErrTc . dupGenericInsts) bad_groups `thenM_`
+
+ -- Check that there is an InstInfo for each generic type constructor
+ let
+ missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
+ in
+ checkTc (null missing) (missingGenericInstances missing) `thenM_`
- -- Find the prags for this method, and replace the
- -- selector name with the method name
-find_prags sel_name meth_name [] = []
-find_prags sel_name meth_name (SpecSig name ty loc : prags)
- | name == sel_name = SpecSig meth_name ty loc : find_prags sel_name meth_name prags
-find_prags sel_name meth_name (InlineSig sense name phase loc : prags)
- | name == sel_name = InlineSig sense meth_name phase loc : find_prags sel_name meth_name prags
-find_prags sel_name meth_name (prag:prags) = find_prags sel_name meth_name prags
+ returnM inst_infos
+
+ where
+ generic_binds :: [(HsType Name, RenamedMonoBinds)]
+ generic_binds = getGenericBinds def_methods
+
+
+---------------------------------
+getGenericBinds :: RenamedMonoBinds -> [(HsType Name, RenamedMonoBinds)]
+ -- Takes a group of method bindings, finds the generic ones, and returns
+ -- them in finite map indexed by the type parameter in the definition.
+
+getGenericBinds EmptyMonoBinds = []
+getGenericBinds (AndMonoBinds m1 m2) = getGenericBinds m1 ++ getGenericBinds m2
+
+getGenericBinds (FunMonoBind id infixop matches loc)
+ = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
+ where
+ wrap ms = FunMonoBind id infixop ms loc
+
+groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
+groupWith op [] = []
+groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
+ where
+ vs = map snd this
+ (this,rest) = partition same_t prs
+ same_t (t',v) = t `eqPatType` t'
+
+eqPatType :: HsType Name -> HsType Name -> Bool
+-- A very simple equality function, only for
+-- type patterns in generic function definitions.
+eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2
+eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatType` s2 && t2 `eqPatType` t2
+eqPatType _ _ = False
+
+---------------------------------
+mkGenericInstance :: Class -> SrcLoc
+ -> (HsType Name, RenamedMonoBinds)
+ -> TcM InstInfo
+
+mkGenericInstance clas loc (hs_ty, binds)
+ -- Make a generic instance declaration
+ -- For example: instance (C a, C b) => C (a+b) where { binds }
+
+ = -- Extract the universally quantified type variables
+ -- and wrap them as forall'd tyvars, so that kind inference
+ -- works in the standard way
+ let
+ sig_tvs = map UserTyVar (nameSetToList (extractHsTyVars hs_ty))
+ hs_forall_ty = mkHsForAllTy (Just sig_tvs) [] hs_ty
+ in
+ -- Type-check the instance type, and check its form
+ tcHsSigType GenPatCtxt hs_forall_ty `thenM` \ forall_inst_ty ->
+ let
+ (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
+ in
+ checkTc (validGenericInstanceType inst_ty)
+ (badGenericInstanceType binds) `thenM_`
+
+ -- Make the dictionary function.
+ newDFunName clas [inst_ty] loc `thenM` \ dfun_name ->
+ let
+ inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
+ dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
+ in
+
+ returnM (InstInfo { iDFunId = dfun_id, iBinds = VanillaInst binds [] })
\end{code}
-Contexts and errors
-~~~~~~~~~~~~~~~~~~~
+%************************************************************************
+%* *
+ Error messages
+%* *
+%************************************************************************
+
\begin{code}
+tcAddDeclCtxt decl thing_inside
+ = addSrcLoc (tcdLoc decl) $
+ addErrCtxt ctxt $
+ thing_inside
+ where
+ thing = case decl of
+ ClassDecl {} -> "class"
+ TySynonym {} -> "type synonym"
+ TyData {tcdND = NewType} -> "newtype"
+ TyData {tcdND = DataType} -> "data type"
+
+ ctxt = hsep [ptext SLIT("In the"), text thing,
+ ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
+
defltMethCtxt clas
= ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
= vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+>
ptext SLIT("was not compiled with -fgenerics")]
+badGenericInstanceType binds
+ = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
+ nest 4 (ppr binds)]
+
+missingGenericInstances missing
+ = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
+
+dupGenericInsts tc_inst_infos
+ = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
+ nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
+ ptext SLIT("All the type patterns for a generic type constructor must be identical")
+ ]
+ where
+ ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst)
+
mixedGenericErr op
= ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
\end{code}
projects / ghc-hetmet.git / blobdiff