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(..) )
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 NameSet ( emptyNameSet )
import Outputable
import Type ( Type, ThetaType, ClassContext,
- mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
+ mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, mkDictTys,
mkSigmaTy, mkForAllTys, mkClassPred, classesOfPreds,
boxedTypeKind, mkArrowKind
)
(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
tyvar_names fundeps class_sigs def_methods pragmas
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
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
| otherwise -- It is locally defined
= recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
tcAddSrcLoc src_loc $
- tcLookupClass class_name `thenNF_Tc` \ clas ->
+ tcLookupTy class_name `thenNF_Tc` \ (_, AClass clas _) ->
tcDefaultMethodBinds clas default_binds class_sigs
\end{code}
-- 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