)
import TcHsSyn ( TcMonoBinds )
-import Inst ( InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs,
- newDicts, newMethod )
-import TcEnv ( TcId, TcEnv, RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo,
+import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs,
+ instToId, newDicts, newMethod )
+import TcEnv ( RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo,
tcLookupClass, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
tcExtendLocalValEnv, tcExtendTyVarEnv
)
import TcBinds ( tcBindWithSigs, tcSpecSigs )
-import TcMonoType ( tcHsRecType, tcRecClassContext, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig )
-import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
-import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcSigTyVars )
+import TcMonoType ( tcHsRecType, tcRecTheta, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig )
+import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
+import TcType ( TcType, TcTyVar, tcInstTyVars )
import TcMonad
import Generics ( mkGenericRhs, validGenericMethodType )
import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
import Class ( classTyVars, classBigSig, classTyCon,
Class, ClassOpItem, DefMeth (..) )
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
-import DataCon ( mkDataCon, notMarkedStrict )
+import DataCon ( mkDataCon )
+import Demand ( StrictnessMark(..) )
import Id ( Id, idType, idName )
import Module ( Module )
import Name ( Name, NamedThing(..) )
-import Name ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts )
+import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts )
import NameSet ( emptyNameSet )
import Outputable
-import Type ( Type, ClassContext, mkTyVarTys, mkDictTys, mkClassPred,
+import Type ( Type, ThetaType, mkTyVarTys, mkPredTys, mkClassPred,
splitTyConApp_maybe, isTyVarTy
)
import Var ( TyVar )
tcdSigs = class_sigs, tcdMeths = def_methods,
tcdSysNames = sys_names, tcdLoc = src_loc})
= -- CHECK ARITY 1 FOR HASKELL 1.4
- doptsTc Opt_GlasgowExts `thenTc` \ glaExts ->
- checkTc (glaExts || length tyvar_names == 1)
- (classArityErr class_name) `thenTc_`
+ doptsTc Opt_GlasgowExts `thenTc` \ gla_ext_opt ->
+ let
+ gla_exts = gla_ext_opt || not (maybeToBool def_methods)
+ -- Accept extensions if gla_exts is on,
+ -- or if we're looking at an interface file decl
+ in -- (in which case def_methods = Nothing
-- LOOK THINGS UP IN THE ENVIRONMENT
tcLookupClass class_name `thenTc` \ clas ->
-- SOURCE-CODE CONSISTENCY CHECKS
(case def_methods of
- Nothing -> returnTc Nothing -- Not source
- Just dms -> checkDefaultBinds clas op_names dms `thenTc` \ dm_env ->
+ Nothing -> -- Not source
+ returnTc Nothing
+
+ Just dms -> -- Source so do error checks
+ checkTc (gla_exts || length tyvar_names == 1)
+ (classArityErr class_name) `thenTc_`
+
+ checkDefaultBinds clas op_names dms `thenTc` \ dm_env ->
checkGenericClassIsUnary clas dm_env `thenTc_`
returnTc (Just dm_env)
) `thenTc` \ mb_dm_env ->
-- CHECK THE CONTEXT
- tcSuperClasses is_rec clas context sc_sel_names `thenTc` \ (sc_theta, sc_sel_ids) ->
+ tcSuperClasses is_rec gla_exts clas context sc_sel_names `thenTc` \ (sc_theta, sc_sel_ids) ->
-- CHECK THE CLASS SIGNATURES,
mapTc (tcClassSig is_rec rec_env clas tyvars mb_dm_env) op_sigs `thenTc` \ sig_stuff ->
-- MAKE THE CLASS DETAILS
let
(op_tys, op_items) = unzip sig_stuff
- sc_tys = mkDictTys sc_theta
+ sc_tys = mkPredTys sc_theta
dict_component_tys = sc_tys ++ op_tys
dict_con = mkDataCon datacon_name
- [notMarkedStrict | _ <- dict_component_tys]
+ [NotMarkedStrict | _ <- dict_component_tys]
[{- No labelled fields -}]
tyvars
[{-No context-}]
\begin{code}
-tcSuperClasses :: RecFlag -> Class
+tcSuperClasses :: RecFlag -> Bool -> Class
-> RenamedContext -- class context
-> [Name] -- Names for superclass selectors
- -> TcM (ClassContext, -- the superclass context
- [Id]) -- superclass selector Ids
+ -> TcM (ThetaType, -- the superclass context
+ [Id]) -- superclass selector Ids
-tcSuperClasses is_rec clas context sc_sel_names
- = -- Check the context.
+tcSuperClasses is_rec gla_exts clas context sc_sel_names
+ = ASSERT( length context == length sc_sel_names )
+ -- Check the context.
-- The renamer has already checked that the context mentions
-- only the type variable of the class decl.
-- For std Haskell check that the context constrains only tyvars
- doptsTc Opt_GlasgowExts `thenTc` \ glaExts ->
- (if glaExts then
- returnTc ()
- else
- mapTc_ check_constraint context
- ) `thenTc_`
+ mapTc_ check_constraint context `thenTc_`
-- Context is already kind-checked
- tcRecClassContext is_rec context `thenTc` \ sc_theta ->
+ tcRecTheta is_rec context `thenTc` \ sc_theta ->
let
sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names]
in
returnTc (sc_theta, sc_sel_ids)
where
- check_constraint sc@(HsPClass c tys)
- = checkTc (all is_tyvar tys) (superClassErr clas sc)
+ check_constraint sc = checkTc (ok sc) (superClassErr clas sc)
+ ok (HsClassP c tys) | gla_exts = True
+ | otherwise = all is_tyvar tys
+ ok (HsIParam _ _) = False -- Never legal
is_tyvar (HsTyVar _) = True
is_tyvar other = False
let
-- Build the selector id and default method id
sel_id = mkDictSelId op_name clas
- dm_id = mkDefaultMethodId dm_name clas global_ty
+ dm_id = mkDefaultMethodId dm_name global_ty
DefMeth dm_name = sig_dm
dm_info = case maybe_dm_env of
- Nothing -> iface_dm_info
+ Nothing -> iface_dm_info
Just dm_env -> mk_src_dm_info dm_env
iface_dm_info = case sig_dm of
let
theta = [(mkClassPred clas inst_tys)]
in
- newDicts origin theta `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
+ newDicts origin theta `thenNF_Tc` \ [this_dict] ->
tcExtendTyVarEnvForMeths tyvars clas_tyvars (
tcMethodBind clas origin clas_tyvars inst_tys theta
binds_in prags False op_item
- ) `thenTc` \ (defm_bind, insts_needed, (_, local_dm_id)) ->
+ ) `thenTc` \ (defm_bind, insts_needed, local_dm_inst) ->
tcAddErrCtxt (defltMethCtxt clas) $
- -- tcMethodBind has checked that the class_tyvars havn't
- -- been unified with each other or another type, but we must
- -- still zonk them before passing them to tcSimplifyAndCheck
- zonkTcSigTyVars clas_tyvars `thenNF_Tc` \ clas_tyvars' ->
-
-- Check the context
- tcSimplifyAndCheck
+ tcSimplifyCheck
(ptext SLIT("class") <+> ppr clas)
- (mkVarSet clas_tyvars')
- this_dict
- insts_needed `thenTc` \ (const_lie, dict_binds) ->
+ clas_tyvars
+ [this_dict]
+ insts_needed `thenTc` \ (const_lie, dict_binds) ->
+
+ -- Simplification can do unification
+ checkSigTyVars clas_tyvars emptyVarSet `thenTc` \ clas_tyvars' ->
let
full_bind = AbsBinds
clas_tyvars'
- [this_dict_id]
- [(clas_tyvars', dm_id, local_dm_id)]
+ [instToId this_dict]
+ [(clas_tyvars', dm_id, instToId local_dm_inst)]
emptyNameSet -- No inlines (yet)
(dict_binds `andMonoBinds` defm_bind)
in
-> [RenamedSig] -- Pramgas (just for this one)
-> Bool -- True <=> This method is from an instance declaration
-> ClassOpItem -- The method selector and default-method Id
- -> TcM (TcMonoBinds, LIE, (LIE, TcId))
+ -> TcM (TcMonoBinds, LIE, Inst)
tcMethodBind clas origin inst_tyvars inst_tys inst_theta
meth_binds prags is_inst_decl (sel_id, dm_info)
= tcGetSrcLoc `thenNF_Tc` \ loc ->
- newMethod origin sel_id inst_tys `thenNF_Tc` \ meth@(_, meth_id) ->
- mkTcSig meth_id loc `thenNF_Tc` \ sig_info ->
+ newMethod origin sel_id inst_tys `thenNF_Tc` \ meth ->
let
+ meth_id = instToId meth
meth_name = idName meth_id
sig_msg = ptext SLIT("When checking the expected type for class method") <+> ppr sel_id
meth_prags = find_prags (idName sel_id) meth_name prags
in
+ mkTcSig meth_id loc `thenNF_Tc` \ sig_info ->
+
-- Figure out what method binding to use
-- If the user suppplied one, use it, else construct a default one
(case find_bind (idName sel_id) meth_name meth_binds of
mkDefMethRhs is_inst_decl clas inst_tys sel_id loc NoDefMeth
= -- No default method
-- Warn only if -fwarn-missing-methods
- doptsTc Opt_WarnMissingMethods `thenNF_Tc` \ warn ->
+ doptsTc Opt_WarnMissingMethods `thenNF_Tc` \ warn ->
warnTc (is_inst_decl && warn)
- (omittedMethodWarn sel_id clas) `thenNF_Tc_`
+ (omittedMethodWarn sel_id) `thenNF_Tc_`
returnTc error_rhs
where
error_rhs = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
-- a type constructor applied to type arguments in the instance decl
-- (checkTc, so False provokes the error)
checkTc (not is_inst_decl || simple_inst)
- (badGenericInstance sel_id clas) `thenTc_`
+ (badGenericInstance sel_id) `thenTc_`
ioToTc (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff) `thenNF_Tc_`
returnTc rhs
= hsep [ptext SLIT("Class"), quotes (ppr clas),
ptext SLIT("does not have a method"), quotes (ppr op)]
-omittedMethodWarn sel_id clas
- = sep [ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id),
- ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
+omittedMethodWarn sel_id
+ = ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
badGenericMethodType op op_ty
= hang (ptext SLIT("Generic method type is too complex"))
4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
ptext SLIT("You can only use type variables, arrows, and tuples")])
-badGenericInstance sel_id clas
+badGenericInstance sel_id
= sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
ptext SLIT("because the instance declaration is not for a simple type (T a b c)"),
- ptext SLIT("(where T is a derivable type constructor)"),
- ptext SLIT("in an instance declaration for") <+> quotes (ppr clas)]
+ ptext SLIT("(where T is a derivable type constructor)")]
mixedGenericErr op
= ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
projects / ghc-hetmet.git / blobdiff