\section[TcClassDcl]{Typechecking class declarations}
\begin{code}
-module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2,
+module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, mkImplicitClassBinds,
tcMethodBind, checkFromThisClass
) where
import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
InPat(..), HsBinds(..), GRHSs(..),
- HsExpr(..), HsLit(..), HsType(..), pprClassAssertion,
- unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName,
+ HsExpr(..), HsLit(..), HsType(..), HsPred(..),
+ pprHsClassAssertion, unguardedRHS,
+ andMonoBinds, andMonoBindList, getTyVarName,
isClassDecl, isClassOpSig, isPragSig, collectMonoBinders
)
import HsPragmas ( ClassPragmas(..) )
RenamedClassOpSig, RenamedMonoBinds,
RenamedContext, RenamedHsDecl, RenamedSig
)
-import TcHsSyn ( TcMonoBinds )
+import TcHsSyn ( TcMonoBinds, idsToMonoBinds )
import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod )
import TcEnv ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo,
tcExtendLocalValEnv
)
import TcBinds ( tcBindWithSigs, tcSpecSigs )
+import TcTyDecls ( mkNewTyConRep )
import TcUnify ( unifyKinds )
import TcMonad
-import TcMonoType ( tcHsType, tcHsTopType, tcExtendTopTyVarScope,
+import TcMonoType ( kcHsType, tcHsTopType, tcExtendTopTyVarScope,
tcContext, checkSigTyVars, sigCtxt, mkTcSig
)
import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr, tcGetTyVar )
+import TcInstUtil ( classDataCon )
import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
import FieldLabel ( firstFieldLabelTag )
import Bag ( unionManyBags, bagToList )
import Class ( mkClass, classBigSig, classSelIds, Class, ClassOpItem )
import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods )
-import MkId ( mkDictSelId, mkDataConId, mkDefaultMethodId )
-import DataCon ( mkDataCon, notMarkedStrict )
-import Id ( Id, setInlinePragma, getIdUnfolding, idType, idName )
+import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
+import DataCon ( mkDataCon, dataConId, dataConWrapId, notMarkedStrict )
+import Id ( Id, setInlinePragma, idUnfolding, idType, idName )
import CoreUnfold ( unfoldingTemplate )
import IdInfo
import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..) )
import NameSet ( emptyNameSet )
import Outputable
-import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
- mkSigmaTy, mkForAllTys, Type, ThetaType,
+import Type ( Type, ThetaType, ClassContext,
+ mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, mkDictTys,
+ mkSigmaTy, mkForAllTys, mkClassPred, classesOfPreds,
boxedTypeKind, mkArrowKind
)
import Var ( tyVarKind, TyVar )
-import VarSet ( mkVarSet )
-import TyCon ( mkAlgTyCon )
+import VarSet ( mkVarSet, emptyVarSet )
+import TyCon ( AlgTyConFlavour(..), mkClassTyCon )
import Unique ( Unique, Uniquable(..) )
import Util
import Maybes ( seqMaybe )
\begin{code}
kcClassDecl (ClassDecl context class_name
tyvar_names fundeps class_sigs def_methods pragmas
- tycon_name datacon_name sc_sel_names src_loc)
+ _ _ _ _ src_loc)
= -- CHECK ARITY 1 FOR HASKELL 1.4
checkTc (opt_GlasgowExts || length tyvar_names == 1)
(classArityErr class_name) `thenTc_`
where
the_class_sigs = filter isClassOpSig class_sigs
- kc_sig (ClassOpSig _ _ _ op_ty loc) = tcAddSrcLoc loc (tcHsType op_ty)
+ kc_sig (ClassOpSig _ _ _ op_ty loc) = tcAddSrcLoc loc (kcHsType op_ty)
\end{code}
tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
(ClassDecl context class_name
tyvar_names fundeps class_sigs def_methods pragmas
- tycon_name datacon_name sc_sel_names src_loc)
+ tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc)
= -- LOOK THINGS UP IN THE ENVIRONMENT
tcLookupTy class_name `thenTc` \ (class_kind, _, AClass rec_class) ->
tcExtendTopTyVarScope class_kind tyvar_names $ \ tyvars _ ->
dict_component_tys = sc_tys ++ op_tys
new_or_data = case dict_component_tys of
- [_] -> NewType
- other -> DataType
+ [_] -> NewTyCon (mkNewTyConRep tycon)
+ other -> DataTyCon
dict_con = mkDataCon datacon_name
[notMarkedStrict | _ <- dict_component_tys]
[{-No context-}]
[{-No existential tyvars-}] [{-Or context-}]
dict_component_tys
- tycon dict_con_id
+ tycon dict_con_id dict_wrap_id
- dict_con_id = mkDataConId dict_con
+ dict_con_id = mkDataConId datacon_wkr_name dict_con
+ dict_wrap_id = mkDataConWrapId dict_con
argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcClassDecl1: argvrcs:" $
ppr tycon_name)
tycon_name
- tycon = mkAlgTyCon tycon_name
- class_kind
- tyvars
- [] -- No context
- argvrcs
- [dict_con] -- Constructors
- [] -- No derivings
- (Just clas) -- Yes! It's a dictionary
- new_or_data
- NonRecursive
+ tycon = mkClassTyCon tycon_name
+ class_kind
+ tyvars
+ argvrcs
+ dict_con -- Constructors
+ clas -- Yes! It's a dictionary
+ new_or_data
in
returnTc clas
\end{code}
tcClassContext :: Name -> Class -> [TyVar]
-> RenamedContext -- class context
-> [Name] -- Names for superclass selectors
- -> TcM s (ThetaType, -- the superclass context
+ -> TcM s (ClassContext, -- the superclass context
[Type], -- types of the superclass dictionaries
[Id]) -- superclass selector Ids
tcContext context `thenTc` \ sc_theta ->
let
- sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta]
+ sc_theta' = classesOfPreds sc_theta
+ sc_tys = mkDictTys sc_theta'
sc_sel_ids = zipWithEqual "tcClassContext" mk_super_id sc_sel_names sc_tys
in
-- Done
- returnTc (sc_theta, sc_tys, sc_sel_ids)
+ returnTc (sc_theta', sc_tys, sc_sel_ids)
where
rec_tyvar_tys = mkTyVarTys rec_tyvars
mk_super_id name dict_ty
- = mkDictSelId name rec_class ty
+ = mkDictSelId name rec_class {- SUP:??? ty
where
ty = mkForAllTys rec_tyvars $
- mkFunTy (mkDictTy rec_class rec_tyvar_tys) dict_ty
+ mkFunTy (mkDictTy rec_class rec_tyvar_tys) dict_ty -}
- check_constraint (c, tys) = checkTc (all is_tyvar tys)
- (superClassErr class_name (c, tys))
+ check_constraint (HsPClass c tys) = checkTc (all is_tyvar tys)
+ (superClassErr class_name (c, tys))
is_tyvar (MonoTyVar _) = True
is_tyvar other = False
tcHsTopType op_ty `thenTc` \ local_ty ->
let
global_ty = mkSigmaTy rec_clas_tyvars
- [(rec_clas, mkTyVarTys rec_clas_tyvars)]
+ [mkClassPred rec_clas (mkTyVarTys rec_clas_tyvars)]
local_ty
-- Build the selector id and default method id
- sel_id = mkDictSelId op_name rec_clas global_ty
+ sel_id = mkDictSelId op_name rec_clas {- SUP:??? global_ty -}
dm_id = mkDefaultMethodId dm_name rec_clas global_ty
final_dm_id = tcAddImportedIdInfo rec_env dm_id
in
-> NF_TcM s (LIE, TcMonoBinds)
tcClassDecl2 (ClassDecl context class_name
- tyvar_names _ class_sigs default_binds pragmas _ _ _ src_loc)
+ tyvar_names _ class_sigs default_binds pragmas _ _ _ _ src_loc)
| not (isLocallyDefined class_name)
= returnNF_Tc (emptyLIE, EmptyMonoBinds)
| otherwise -- It is locally defined
= recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
tcAddSrcLoc src_loc $
-
- -- Get the relevant class
tcLookupClass class_name `thenNF_Tc` \ clas ->
- let
+ tcDefaultMethodBinds clas default_binds class_sigs
+\end{code}
+
+\begin{code}
+mkImplicitClassBinds :: [Class] -> NF_TcM s ([Id], TcMonoBinds)
+mkImplicitClassBinds classes
+ = returnNF_Tc (concat cls_ids_s, andMonoBindList binds_s)
-- The selector binds are already in the selector Id's unfoldings
- sel_binds = [ CoreMonoBind sel_id (unfoldingTemplate (getIdUnfolding sel_id))
- | sel_id <- classSelIds clas
- ]
- in
- -- Generate bindings for the default methods
- tcDefaultMethodBinds clas default_binds class_sigs `thenTc` \ (const_insts, meth_binds) ->
+ where
+ (cls_ids_s, binds_s) = unzip (map mk_implicit classes)
+
+ mk_implicit clas = (all_cls_ids, binds)
+ where
+ dict_con = classDataCon clas
+ all_cls_ids = dataConId dict_con : cls_ids
+ cls_ids = dataConWrapId dict_con : classSelIds clas
- returnTc (const_insts,
- meth_binds `AndMonoBinds` andMonoBindList sel_binds)
+ -- The wrapper and selectors get bindings, the worker does not
+ binds | isLocallyDefined clas = idsToMonoBinds cls_ids
+ | otherwise = EmptyMonoBinds
\end{code}
%************************************************************************
tc_dm op_item@(_, dm_id, _)
= tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
let
- theta = [(clas,inst_tys)]
+ theta = [(mkClassPred clas inst_tys)]
in
newDicts origin theta `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
let
-- Now check that the instance type variables
-- (or, in the case of a class decl, the class tyvars)
-- have not been unified with anything in the environment
- tcAddErrCtxtM (sigCtxt sig_msg (mkSigmaTy inst_tyvars inst_theta (idType meth_id))) $
- checkSigTyVars inst_tyvars `thenTc_`
+ tcAddErrCtxtM (sigCtxt sig_msg inst_tyvars inst_theta (idType meth_id)) $
+ checkSigTyVars inst_tyvars emptyVarSet `thenTc_`
returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2,
insts `plusLIE` prag_lie',
meth)
where
- sig_msg ty = sep [ptext SLIT("When checking the expected type for"),
- nest 4 (ppr sel_name <+> dcolon <+> ppr ty)]
+ sig_msg = ptext SLIT("When checking the expected type for class method") <+> ppr sel_name
sel_name = idName sel_id
= ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
superClassErr class_name sc
- = ptext SLIT("Illegal superclass constraint") <+> quotes (pprClassAssertion sc)
+ = ptext SLIT("Illegal superclass constraint") <+> quotes (pprHsClassAssertion sc)
<+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name)
defltMethCtxt class_name
projects / ghc-hetmet.git / blobdiff