X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcClassDcl.lhs;h=820ed749f5a100788c6196d3a06ed98793065266;hb=3c6b9911369deda84fcc74a31372e6f51e0cb054;hp=191ff058bf27c022df9b0c9828eee5976e5521d9;hpb=4e84be0ce335385e094ba12d284855b510a36f53;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 191ff05..820ed74 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -16,7 +16,7 @@ import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..), isClassOpSig, isPragSig, placeHolderType ) -import BasicTypes ( RecFlag(..), StrictnessMark(..) ) +import BasicTypes ( RecFlag(..) ) import RnHsSyn ( RenamedTyClDecl, RenamedSig, RenamedClassOpSig, RenamedMonoBinds, maybeGenericMatch @@ -24,19 +24,21 @@ import RnHsSyn ( RenamedTyClDecl, RenamedSig, import RnEnv ( lookupSysName ) import TcHsSyn ( TcMonoBinds ) -import Inst ( Inst, InstOrigin(..), instToId, newDicts, tcInstClassOp ) +import Inst ( Inst, InstOrigin(..), instToId, newDicts, newMethod ) import TcEnv ( TyThingDetails(..), - tcLookupClass, tcExtendTyVarEnv2, - tcExtendTyVarEnv + tcLookupClass, tcExtendLocalValEnv2, + tcExtendTyVarEnv2, tcExtendTyVarEnv ) -import TcBinds ( tcMonoBinds ) +import TcTyDecls ( tcMkDataCon ) +import TcBinds ( tcMonoBinds, tcSpecSigs ) import TcMonoType ( TcSigInfo(..), tcHsType, tcHsTheta, mkTcSig ) -import TcSimplify ( tcSimplifyCheck ) +import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns ) import TcUnify ( checkSigTyVars, sigCtxt ) import TcMType ( tcInstTyVars ) import TcType ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar, mkTyVarTys, mkPredTys, mkClassPred, tcSplitSigmaTy, tcSplitFunTys, - tcIsTyVarTy, tcSplitTyConApp_maybe + tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy, + getClassPredTys_maybe, mkPhiTy ) import TcRnMonad import Generics ( mkGenericRhs ) @@ -44,19 +46,19 @@ import PrelInfo ( nO_METHOD_BINDING_ERROR_ID ) import Class ( classTyVars, classBigSig, classTyCon, Class, ClassOpItem, DefMeth (..) ) import TyCon ( tyConGenInfo ) -import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId ) -import DataCon ( mkDataCon ) -import Id ( Id, idType, idName, setIdLocalExported, setInlinePragma ) +import Subst ( substTyWith ) +import MkId ( mkDictSelId, mkDefaultMethodId ) +import Id ( Id, idType, idName, mkUserLocal, setInlinePragma ) import Name ( Name, NamedThing(..) ) import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv ) import NameSet ( emptyNameSet, unitNameSet ) -import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc, mkSuperDictSelOcc ) +import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, reportIfUnused ) import Outputable import Var ( TyVar ) import CmdLineOpts import UnicodeUtil ( stringToUtf8 ) import ErrUtils ( dumpIfSet ) -import Util ( count, lengthIs ) +import Util ( count, lengthIs, isSingleton ) import Maybes ( seqMaybe ) import Maybe ( isJust ) import FastString @@ -119,7 +121,7 @@ tcClassDecl1 (ClassDecl {tcdCtxt = context, tcdName = class_name, in tcExtendTyVarEnv tyvars $ - checkDefaultBinds clas op_names def_methods `thenM` \ mb_dm_env -> + checkDefaultBinds clas op_names def_methods `thenM` \ mb_dm_env -> -- CHECK THE CONTEXT -- The renamer has already checked that the context mentions @@ -131,8 +133,8 @@ tcClassDecl1 (ClassDecl {tcdCtxt = context, tcdName = class_name, mappM (tcClassSig clas tyvars mb_dm_env) op_sigs `thenM` \ sig_stuff -> -- MAKE THE CLASS DETAILS - lookupSysName class_name mkClassDataConOcc `thenM` \ datacon_name -> - lookupSysName datacon_name mkWorkerOcc `thenM` \ datacon_wkr_name -> + lookupSysName class_name mkClassTyConOcc `thenM` \ tycon_name -> + lookupSysName class_name mkClassDataConOcc `thenM` \ datacon_name -> mapM (lookupSysName class_name . mkSuperDictSelOcc) [1..length context] `thenM` \ sc_sel_names -> -- We number off the superclass selectors, 1, 2, 3 etc so that we @@ -142,26 +144,20 @@ tcClassDecl1 (ClassDecl {tcdCtxt = context, tcdName = class_name, -- D_sc1, D_sc2 -- (We used to call them D_C, but now we can have two different -- superclasses both called C!) - lookupSysName class_name mkClassTyConOcc `thenM` \ tycon_name -> let (op_tys, op_items) = unzip sig_stuff sc_tys = mkPredTys sc_theta dict_component_tys = sc_tys ++ op_tys sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names] - - dict_con = mkDataCon datacon_name - [NotMarkedStrict | _ <- dict_component_tys] - [{- No labelled fields -}] - tyvars - [{-No context-}] - [{-No existential tyvars-}] [{-Or context-}] - dict_component_tys - (classTyCon clas) - dict_con_id dict_wrap_id - - dict_con_id = mkDataConId datacon_wkr_name dict_con - dict_wrap_id = mkDataConWrapId dict_con in + tcMkDataCon datacon_name + [{- No strictness -}] + [{- No labelled fields -}] + tyvars [{-No context-}] + [{-No existential tyvars-}] [{-Or context-}] + dict_component_tys + (classTyCon clas) `thenM` \ dict_con -> + returnM (class_name, ClassDetails sc_theta sc_sel_ids op_items dict_con tycon_name) \end{code} @@ -376,23 +372,14 @@ tcDefMeth clas tyvars binds_in prags (_, GenDefMeth) = returnM (EmptyMonoBinds, tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name) = tcInstTyVars ClsTv tyvars `thenM` \ (clas_tyvars, inst_tys, _) -> let - dm_ty = idType sel_id -- Same as dict selector! - -- The default method's type should really come from the - -- iface file, since it could be usage-generalised, but this - -- requires altering the mess of knots in TcModule and I'm - -- too scared to do that. Instead, I have disabled generalisation - -- of types of default methods (and dict funs) by annotating them - -- TyGenNever (in MkId). Ugh! KSW 1999-09. - + dm_ty = idType sel_id -- Same as dict selector! theta = [mkClassPred clas inst_tys] - dm_id = mkDefaultMethodId dm_name dm_ty - local_dm_id = setIdLocalExported dm_id - -- Reason for setIdLocalExported: see notes with MkId.mkDictFunId - xtve = tyvars `zip` clas_tyvars + local_dm_id = mkDefaultMethodId dm_name dm_ty + xtve = tyvars `zip` clas_tyvars in newDicts origin theta `thenM` \ [this_dict] -> - mkMethodBind origin clas inst_tys binds_in op_item `thenM` \ (dm_inst, meth_info) -> + mkMethodBind origin clas inst_tys binds_in op_item `thenM` \ (_, meth_info) -> getLIE (tcMethodBind xtve clas_tyvars theta [this_dict] prags meth_info) `thenM` \ (defm_bind, insts_needed) -> @@ -409,14 +396,15 @@ tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name) checkSigTyVars clas_tyvars `thenM` \ clas_tyvars' -> let + (_,dm_inst_id,_) = meth_info full_bind = AbsBinds clas_tyvars' [instToId this_dict] - [(clas_tyvars', local_dm_id, instToId dm_inst)] + [(clas_tyvars', local_dm_id, dm_inst_id)] emptyNameSet -- No inlines (yet) (dict_binds `andMonoBinds` defm_bind) in - returnM (full_bind, [dm_id]) + returnM (full_bind, [local_dm_id]) where origin = ClassDeclOrigin \end{code} @@ -436,7 +424,7 @@ tyvar sets. \begin{code} type MethodSpec = (Id, -- Global selector Id - TcSigInfo, -- Signature + Id, -- Local Id (class tyvars instantiated) RenamedMonoBinds) -- Binding for the method tcMethodBind @@ -454,13 +442,16 @@ tcMethodBind -> TcM TcMonoBinds tcMethodBind xtve inst_tyvars inst_theta avail_insts prags - (sel_id, meth_sig, meth_bind) + (sel_id, meth_id, meth_bind) = -- Check the bindings; first adding inst_tyvars to the envt -- so that we don't quantify over them in nested places + mkTcSig meth_id `thenM` \ meth_sig -> + tcExtendTyVarEnv2 xtve ( - addErrCtxt (methodCtxt sel_id) $ - getLIE (tcMonoBinds meth_bind [meth_sig] NonRecursive) - ) `thenM` \ ((meth_bind, _, _), meth_lie) -> + addErrCtxt (methodCtxt sel_id) $ + getLIE $ + tcMonoBinds meth_bind [meth_sig] NonRecursive + ) `thenM` \ ((meth_bind,_), meth_lie) -> -- Now do context reduction. We simplify wrt both the local tyvars -- and the ones of the class/instance decl, so that there is @@ -486,42 +477,56 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags checkSigTyVars all_tyvars `thenM` \ all_tyvars' -> let + sel_name = idName sel_id + inline_prags = [ (is_inl, phase) + | InlineSig is_inl name phase _ <- prags, + name == sel_name ] + spec_prags = [ prag + | prag@(SpecSig name _ _) <- prags, + name == sel_name] + -- Attach inline pragmas as appropriate (final_meth_id, inlines) - | (InlineSig inl _ phase _ : _) <- filter is_inline prags + | ((is_inline, phase) : _) <- inline_prags = (meth_id `setInlinePragma` phase, - if inl then unitNameSet (idName meth_id) else emptyNameSet) + if is_inline then unitNameSet (idName meth_id) else emptyNameSet) | otherwise = (meth_id, emptyNameSet) - is_inline (InlineSig _ name _ _) = name == idName sel_id - is_inline other = False - meth_tvs' = take (length meth_tvs) all_tyvars' poly_meth_bind = AbsBinds meth_tvs' (map instToId meth_dicts) [(meth_tvs', final_meth_id, local_meth_id)] inlines (lie_binds `andMonoBinds` meth_bind) + in - returnM poly_meth_bind + -- Deal with specialisation pragmas + -- The sel_name is what appears in the pragma + tcExtendLocalValEnv2 [(sel_name, final_meth_id)] ( + getLIE (tcSpecSigs spec_prags) `thenM` \ (spec_binds1, prag_lie) -> + + -- The prag_lie for a SPECIALISE pragma will mention the function itself, + -- so we have to simplify them away right now lest they float outwards! + bindInstsOfLocalFuns prag_lie [final_meth_id] `thenM` \ spec_binds2 -> + returnM (spec_binds1 `andMonoBinds` spec_binds2) + ) `thenM` \ spec_binds -> + + returnM (poly_meth_bind `andMonoBinds` spec_binds) mkMethodBind :: InstOrigin -> Class -> [TcType] -- Class and instance types -> RenamedMonoBinds -- Method binding (pick the right one from in here) -> ClassOpItem - -> TcM (Inst, -- Method inst + -> TcM (Maybe Inst, -- Method inst MethodSpec) -- Find the binding for the specified method, or make -- up a suitable default method if it isn't there mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info) - = getInstLoc origin `thenM` \ inst_loc -> - tcInstClassOp inst_loc sel_id inst_tys `thenM` \ meth_inst -> - -- Do not dump anything into the LIE + = mkMethId origin clas sel_id inst_tys `thenM` \ (mb_inst, meth_id) -> let - meth_id = instToId meth_inst meth_name = idName meth_id in -- Figure out what method binding to use @@ -531,13 +536,52 @@ mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info) Just user_bind -> returnM user_bind Nothing -> mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs -> returnM (FunMonoBind meth_name False -- Not infix decl - [mkSimpleMatch [] rhs placeHolderType loc] loc) + [mkSimpleMatch [] rhs placeHolderType loc] loc) ) `thenM` \ meth_bind -> - mkTcSig meth_id loc `thenM` \ meth_sig -> - - returnM (meth_inst, (sel_id, meth_sig, meth_bind)) - + returnM (mb_inst, (sel_id, meth_id, meth_bind)) + +mkMethId :: InstOrigin -> Class + -> Id -> [TcType] -- Selector, and instance types + -> TcM (Maybe Inst, Id) + +-- mkMethId instantiates the selector Id at the specified types +mkMethId origin clas sel_id inst_tys + = let + (tyvars,rho) = tcSplitForAllTys (idType sel_id) + rho_ty = ASSERT( length tyvars == length inst_tys ) + substTyWith tyvars inst_tys rho + (preds,tau) = tcSplitPhiTy rho_ty + first_pred = head preds + in + -- The first predicate should be of form (C a b) + -- where C is the class in question + ASSERT( not (null preds) && + case getClassPredTys_maybe first_pred of + { Just (clas1,tys) -> clas == clas1 ; Nothing -> False } + ) + if isSingleton preds then + -- If it's the only one, make a 'method' + getInstLoc origin `thenM` \ inst_loc -> + newMethod inst_loc sel_id inst_tys preds tau `thenM` \ meth_inst -> + returnM (Just meth_inst, instToId meth_inst) + else + -- If it's not the only one we need to be careful + -- For example, given 'op' defined thus: + -- class Foo a where + -- op :: (?x :: String) => a -> a + -- (mkMethId op T) should return an Inst with type + -- (?x :: String) => T -> T + -- That is, the class-op's context is still there. + -- BUT: it can't be a Method any more, because it breaks + -- INVARIANT 2 of methods. (See the data decl for Inst.) + newUnique `thenM` \ uniq -> + getSrcLocM `thenM` \ loc -> + let + real_tau = mkPhiTy (tail preds) tau + meth_id = mkUserLocal (getOccName sel_id) uniq real_tau loc + in + returnM (Nothing, meth_id) -- The user didn't supply a method binding, -- so we have to make up a default binding @@ -551,7 +595,9 @@ mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth = -- No default method -- Warn only if -fwarn-missing-methods doptM Opt_WarnMissingMethods `thenM` \ warn -> - warnTc (isInstDecl origin && warn) + warnTc (isInstDecl origin + && warn + && reportIfUnused (getOccName sel_id)) (omittedMethodWarn sel_id) `thenM_` returnM error_rhs where