\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(..), HsPred(..),
- pprHsClassAssertion, unguardedRHS,
- andMonoBinds, andMonoBindList, getTyVarName,
+ mkSimpleMatch,
+ 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,
- tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
+ tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
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 ( Type, ThetaType, ClassContext,
- mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
+ 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_`
-- Get the (mutable) class kind
- tcLookupTy class_name `thenNF_Tc` \ (kind, _, _) ->
+ tcLookupTy class_name `thenNF_Tc` \ (kind, _) ->
-- Make suitable tyvars and do kind checking
-- The net effect is to mutate the class kind
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) ->
+ tcLookupTy class_name `thenTc` \ (class_kind, AClass rec_class arity) ->
tcExtendTopTyVarScope class_kind tyvar_names $ \ tyvars _ ->
-- The class kind is by now immutable
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
+ returnTc (class_name, AClass clas arity)
\end{code}
\begin{code}
mapTc tc_fd_tyvar vs `thenTc` \ vs' ->
returnTc (us', vs')
tc_fd_tyvar v =
- tcLookupTy v `thenTc` \(_, _, thing) ->
- case thing of
- ATyVar tv -> returnTc tv
- -- ZZ else should fail more gracefully
+ tcLookupTy v `thenTc` \(_, ATyVar tv) ->
+ returnTc tv
\end{code}
\begin{code}
let
sc_theta' = classesOfPreds sc_theta
- sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta']
- sc_sel_ids = zipWithEqual "tcClassContext" mk_super_id sc_sel_names sc_tys
+ sc_tys = mkDictTys sc_theta'
+ sc_sel_ids = [mkDictSelId sc_name rec_class | sc_name <- sc_sel_names]
in
-- Done
returnTc (sc_theta', sc_tys, sc_sel_ids)
where
- rec_tyvar_tys = mkTyVarTys rec_tyvars
+ check_constraint sc@(HsPClass c tys) = checkTc (all is_tyvar tys)
+ (superClassErr class_name sc)
- mk_super_id name dict_ty
- = mkDictSelId name rec_class ty
- where
- ty = mkForAllTys rec_tyvars $
- mkFunTy (mkDictTy rec_class rec_tyvar_tys) dict_ty
-
- check_constraint (HsPClass c tys) = checkTc (all is_tyvar tys)
- (superClassErr class_name (c, tys))
-
- is_tyvar (MonoTyVar _) = True
- is_tyvar other = False
+ is_tyvar (HsTyVar _) = True
+ is_tyvar other = False
tcClassSig :: ValueEnv -- Knot tying only!
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
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 $
+ tcLookupTy class_name `thenNF_Tc` \ (_, AClass clas _) ->
+ tcDefaultMethodBinds clas default_binds class_sigs
+\end{code}
- -- Get the relevant class
- tcLookupClass class_name `thenNF_Tc` \ clas ->
- let
+\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}
%************************************************************************
-- 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
-- but we must use the method name; so we substitute it here. Crude but simple.
find_bind meth_name (FunMonoBind op_name fix matches loc)
| op_name == sel_name = Just (FunMonoBind meth_name fix matches loc)
- find_bind meth_name (PatMonoBind (VarPatIn op_name) grhss loc)
- | op_name == sel_name = Just (PatMonoBind (VarPatIn meth_name) grhss loc)
find_bind meth_name (AndMonoBinds b1 b2)
= find_bind meth_name b1 `seqMaybe` find_bind meth_name b2
find_bind meth_name other = Nothing -- Default case
find_prags meth_name (prag:prags) = find_prags meth_name prags
mk_default_bind local_meth_name loc
- = PatMonoBind (VarPatIn local_meth_name)
- (GRHSs (unguardedRHS (default_expr loc) loc) EmptyBinds Nothing)
+ = FunMonoBind local_meth_name
+ False -- Not infix decl
+ [mkSimpleMatch [] (default_expr loc) Nothing loc]
loc
default_expr loc
= ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
superClassErr class_name sc
- = ptext SLIT("Illegal superclass constraint") <+> quotes (pprHsClassAssertion sc)
+ = ptext SLIT("Illegal superclass constraint") <+> quotes (ppr sc)
<+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name)
defltMethCtxt class_name
projects / ghc-hetmet.git / blobdiff