import HsPragmas ( ClassPragmas(..) )
import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
RenamedClassOpSig(..), RenamedMonoBinds(..),
- RenamedGenPragmas(..), RenamedContext(..) )
+ RenamedGenPragmas(..), RenamedContext(..),
+ RnName{-instance Uniquable-}
+ )
import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..),
mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, unZonkId )
-import TcMonad
-import GenSpecEtc ( specTy )
+import TcMonad hiding ( rnMtoTcM )
import Inst ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts )
import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds)
import TcInstDcls ( processInstBinds )
import TcKind ( unifyKind )
import TcMonoType ( tcMonoType, tcContext )
-import TcType ( TcTyVar(..), tcInstType, tcInstTyVar )
+import TcType ( TcType(..), TcTyVar(..), tcInstType, tcInstSigTyVars )
import TcKind ( TcKind )
import Bag ( foldBag )
-import Class ( GenClass, mkClass, mkClassOp, getClassBigSig,
- getClassOps, getClassOpString, getClassOpLocalType )
-import CoreUtils ( escErrorMsg )
+import Class ( GenClass, mkClass, mkClassOp, classBigSig,
+ classOps, classOpString, classOpLocalType,
+ classOpTagByString
+ )
import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
idType )
import IdInfo ( noIdInfo )
-import Name ( Name, getNameFullName, getTagFromClassOpName )
-import PrelVals ( pAT_ERROR_ID )
+import Name ( isLocallyDefined, moduleNamePair, getLocalName )
+import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID )
import PprStyle
import Pretty
import PprType ( GenType, GenTyVar, GenClassOp )
import SpecEnv ( SpecEnv(..) )
import SrcLoc ( mkGeneratedSrcLoc )
-import Type ( mkFunTy, mkTyVarTy, mkDictTy,
+import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
mkForAllTy, mkSigmaTy, splitSigmaTy)
import TysWiredIn ( stringTy )
import TyVar ( GenTyVar )
`thenTc` \ sig_stuff ->
-- MAKE THE CLASS OBJECT ITSELF
- tcGetUnique `thenNF_Tc` \ uniq ->
+-- BOGUS:
+-- tcGetUnique `thenNF_Tc` \ uniq ->
let
(ops, op_sel_ids, defm_ids) = unzip3 sig_stuff
- clas = mkClass uniq (getNameFullName class_name) rec_tyvar
+ clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar
scs sc_sel_ids ops op_sel_ids defm_ids
rec_class_inst_env
in
full_theta = (rec_clas, mkTyVarTy rec_clas_tyvar) : theta
global_ty = mkSigmaTy full_tyvars full_theta tau
local_ty = mkSigmaTy tyvars theta tau
- class_op = mkClassOp (getOccurrenceName op_name)
- (getTagFromClassOpName op_name)
+ class_op_nm = getLocalName op_name
+ class_op = mkClassOp class_op_nm
+ (classOpTagByString rec_clas{-yeeps!-} class_op_nm)
local_ty
in
-- Build the selector id and default method id
tcGetUnique `thenNF_Tc` \ d_uniq ->
let
- op_uniq = getItsUnique op_name
+ op_uniq = uniqueOf op_name
sel_id = mkMethodSelId op_uniq rec_clas class_op global_ty op_info
defm_id = mkDefaultMethodId d_uniq rec_clas class_op False global_ty defm_info
-- ToDo: improve the "False"
tcClassDecl2 (ClassDecl context class_name
tyvar_name class_sigs default_binds pragmas src_loc)
+
+ | not (isLocallyDefined class_name)
+ = returnNF_Tc (emptyLIE, EmptyBinds)
+
+ | otherwise -- It is locally defined
= recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
tcAddSrcLoc src_loc $
tcLookupClass class_name `thenNF_Tc` \ (_, clas) ->
let
(tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
- = getClassBigSig clas
+ = classBigSig clas
in
- tcInstTyVar tyvar `thenNF_Tc` \ clas_tyvar ->
+ tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], _, _) ->
-- Generate bindings for the selector functions
- buildSelectors clas clas_tyvar scs sc_sel_ids ops op_sel_ids
- `thenNF_Tc` \ sel_binds ->
+ buildSelectors clas tyvar clas_tyvar scs sc_sel_ids ops op_sel_ids
+ `thenNF_Tc` \ sel_binds ->
-- Ditto for the methods
buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds
- `thenTc` \ (const_insts, meth_binds) ->
+ `thenTc` \ (const_insts, meth_binds) ->
returnTc (const_insts, sel_binds `ThenBinds` meth_binds)
\end{code}
\begin{code}
buildSelectors :: Class -- The class object
- -> TcTyVar s -- Class type variable
+ -> 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 scs sc_sel_ids ops op_sel_ids
+buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids
=
-- Make new Ids for the components of the dictionary
- mapNF_Tc (tcInstType [] . getClassOpLocalType) ops `thenNF_Tc` \ op_tys ->
-
- newLocalIds (map getClassOpString ops) op_tys `thenNF_Tc` \ method_ids ->
+ 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, mkTyVarTy clas_tyvar)
+ [ (super_clas, clas_tyvar_ty)
| super_clas <- scs ] `thenNF_Tc` \ (_,dict_ids) ->
newDicts ClassDeclOrigin
- [ (clas, mkTyVarTy clas_tyvar) ] `thenNF_Tc` \ (_,[clas_dict]) ->
+ [ (clas, clas_tyvar_ty) ] `thenNF_Tc` \ (_,[clas_dict]) ->
-- Make suitable bindings for the selectors
let
- tc_method_ids = map TcId method_ids
-
mk_sel sel_id method_or_dict
- = mkSelBind sel_id clas_tyvar clas_dict dict_ids tc_method_ids method_or_dict
+ = mkSelBind sel_id clas_tc_tyvar clas_dict dict_ids method_ids method_or_dict
in
- listNF_Tc (zipWithEqual mk_sel op_sel_ids tc_method_ids) `thenNF_Tc` \ op_sel_binds ->
- listNF_Tc (zipWithEqual mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds ->
+ listNF_Tc (zipWithEqual mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds ->
+ listNF_Tc (zipWithEqual mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds ->
returnNF_Tc (SingleBind (
NonRecBind (
mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
= let
(op_tyvars,op_theta,op_tau) = splitSigmaTy (idType op)
- op_tys = map mkTyVarTy op_tyvars
+ op_tys = mkTyVarTys op_tyvars
in
newDicts ClassDeclOrigin op_theta `thenNF_Tc` \ (_, op_dicts) ->
= /\ a -> \ dfoo_a ->
let rec
op1 = defm.Foo.op1 [a] dfoo_list
- op2 = /\b -> defm.Foo.op2 [a] b dfoo_list
+ op2 = /\b -> \dord -> defm.Foo.op2 [a] b dfoo_list dord
dfoo_list = (op1, op2)
in
dfoo_list
= -- Deal with the method declarations themselves
mapNF_Tc unZonkId default_method_ids `thenNF_Tc` \ tc_defm_ids ->
processInstBinds
+ clas
(makeClassDeclDefaultMethodRhs clas default_method_ids)
[] -- No tyvars in scope for "this inst decl"
emptyLIE -- No insts available
-> NF_TcM s (TcExpr s)
makeClassDeclDefaultMethodRhs clas method_ids tag
- = specTy ClassDeclOrigin (idType method_id) `thenNF_Tc` \ (tyvars, dicts, tau, dict_ids) ->
+ = tcInstType [] (idType method_id) `thenNF_Tc` \ method_ty ->
+ let
+ (tyvars, theta, tau) = splitSigmaTy method_ty
+ in
+ newDicts ClassDeclOrigin theta `thenNF_Tc` \ (lie, dict_ids) ->
returnNF_Tc (mkHsTyLam tyvars (
mkHsDictLam dict_ids (
- HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [tau])
+ HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tau])
(HsLitOut (HsString (_PK_ error_msg)) stringTy))))
where
- (clas_mod, clas_name) = getOrigName clas
+ (clas_mod, clas_name) = moduleNamePair clas
method_id = method_ids !! (tag-1)
- class_op = (getClassOps clas) !! (tag-1)
-
- error_msg = "%D" -- => No default method for \"
- ++ unencoded_part_of_msg
+ class_op = (classOps clas) !! (tag-1)
- unencoded_part_of_msg = escErrorMsg (
- _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
- ++ (ppShow 80 (ppr PprForUser class_op))
- ++ "\"" )
+ error_msg = _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
+ ++ (ppShow 80 (ppr PprForUser class_op))
+ ++ "\""
\end{code}
projects / ghc-hetmet.git / blobdiff