-%************************************************************************
-%* *
-\subsection[ClassDcl-bld-sels]{Building the selector functions for methods and superclasses}
-%* *
-%************************************************************************
-
-\begin{code}
-buildSelectors :: Class -- The class object
- -> TyVar -- Class type variable
- -> TcTyVar s -- Instantiated class type variable (TyVarTy)
- -> [Class] -> [Id] -- Superclasses and selectors
- -> [ClassOp] -> [Id] -- Class ops and selectors
- -> NF_TcM s (TcHsBinds s)
-
-buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids
- =
- -- Make new Ids for the components of the dictionary
- let
- clas_tyvar_ty = mkTyVarTy clas_tc_tyvar
- mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . classOpLocalType
- in
- mapNF_Tc mk_op_ty ops `thenNF_Tc` \ op_tys ->
- newLocalIds (map classOpString ops) op_tys `thenNF_Tc` \ method_ids ->
-
- newDicts ClassDeclOrigin
- [ (super_clas, clas_tyvar_ty)
- | super_clas <- scs ] `thenNF_Tc` \ (_,dict_ids) ->
-
- newDicts ClassDeclOrigin
- [ (clas, clas_tyvar_ty) ] `thenNF_Tc` \ (_,[clas_dict]) ->
-
- -- Make suitable bindings for the selectors
- let
- mk_sel sel_id method_or_dict
- = mkSelBind sel_id clas_tc_tyvar clas_dict dict_ids method_ids method_or_dict
- in
- listNF_Tc (zipWithEqual "mk_sel1" mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds ->
- listNF_Tc (zipWithEqual "mk_sel2" mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds ->
-
- returnNF_Tc (SingleBind (
- NonRecBind (
- foldr AndMonoBinds
- (foldr AndMonoBinds EmptyMonoBinds op_sel_binds)
- sc_sel_binds
- )))
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[ClassDcl-misc]{Miscellaneous}
-%* *
-%************************************************************************
-
-Make a selector expression for @sel_id@ from a dictionary @clas_dict@
-consisting of @dicts@ and @methods@.
-
-====================== OLD ============================
-We have to do a bit of jiggery pokery to get the type variables right.
-Suppose we have the class decl:
-\begin{verbatim}
- class Foo a where
- op1 :: Ord b => a -> b -> a
- op2 :: ...
-\end{verbatim}
-Then the method selector for \tr{op1} is like this:
-\begin{verbatim}
- op1_sel = /\a b -> \dFoo dOrd -> case dFoo of
- (op1_method,op2_method) -> op1_method b dOrd
-\end{verbatim}
-Note that the type variable for \tr{b} and the (Ord b) dictionary
-are lifted to the top lambda, and
-\tr{op1_method} is applied to them. This is preferable to the alternative:
-\begin{verbatim}
- op1_sel' = /\a -> \dFoo -> case dFoo of
- (op1_method,op2_method) -> op1_method
-\end{verbatim}
-because \tr{op1_sel'} then has the rather strange type
-\begin{verbatim}
- op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a
-\end{verbatim}
-whereas \tr{op1_sel} (the one we use) has the decent type
-\begin{verbatim}
- op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
-\end{verbatim}
-========================= END OF OLD ===========================
-
-NEW COMMENT: instead we now go for op1_sel' above. Seems tidier and
-the rest of the compiler darn well ought to cope.
-
-
-
-NOTE that we return a TcMonoBinds (which is later zonked) even though
-there's no real back-substitution to do. It's just simpler this way!
-
-NOTE ALSO that the selector has no free type variables, so we
-don't bother to instantiate the class-op's local type; instead
-we just use the variables inside it.
-
-\begin{code}
-mkSelBind :: Id -- the selector id
- -> TcTyVar s -> TcIdOcc s -- class tyvar and dict
- -> [TcIdOcc s] -> [TcIdOcc s] -- superclasses and methods in class dict
- -> TcIdOcc s -- the superclass/method being slected
- -> NF_TcM s (TcMonoBinds s)
-
-mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
- =
- -- sel_id = /\ clas_tyvar -> \ clas_dict ->
- -- case clas_dict of
- -- <dicts..methods> -> method_or_dict
-
- returnNF_Tc (VarMonoBind (RealId sel_id) (
- TyLam [clas_tyvar] (
- DictLam [clas_dict] (
- HsCase
- (HsVar clas_dict)
- ([PatMatch (DictPat dicts methods) (
- GRHSMatch (GRHSsAndBindsOut
- [OtherwiseGRHS
- (HsVar method_or_dict)
- mkGeneratedSrcLoc]
- EmptyBinds
- (idType op)))])
- mkGeneratedSrcLoc
- ))))
-\end{code}