X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=3ea432f2a073a558ffe437d9e1e9b67895f509bb;hb=f01a8e8c9c53bfb5ab3393ed3457ebf25390efa1;hp=6e3db5bc9d45720ce7ba62aff1d7383002ab3a9c;hpb=0596517a9b4b2b32e5d375a986351102ac4540fc;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 6e3db5b..3ea432f 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -23,15 +23,17 @@ import HsSyn ( InstDecl(..), FixityDecl, Sig(..), PolyType(..), MonoType ) import RnHsSyn ( RenamedHsBinds(..), RenamedMonoBinds(..), RenamedInstDecl(..), RenamedFixityDecl(..), - RenamedSig(..), RenamedSpecInstSig(..) ) + RenamedSig(..), RenamedSpecInstSig(..), + RnName(..){-incl instance Outputable-} + ) import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), - TcMonoBinds(..), TcExpr(..), + TcMonoBinds(..), TcExpr(..), tcIdType, mkHsTyLam, mkHsTyApp, mkHsDictLam, mkHsDictApp ) import TcMonad -import GenSpecEtc ( checkSigTyVars, specTy ) +import GenSpecEtc ( checkSigTyVars ) import Inst ( Inst, InstOrigin(..), InstanceMapper(..), newDicts, newMethod, LIE(..), emptyLIE, plusLIE ) import TcBinds ( tcPragmaSigs ) @@ -44,7 +46,8 @@ import TcMatches ( tcMatchesFun ) import TcMonoType ( tcContext, tcMonoTypeKind ) import TcSimplify ( tcSimplifyAndCheck, tcSimplifyThetas ) import TcType ( TcType(..), TcTyVar(..), - tcInstTyVar, tcInstType, tcInstTheta ) + tcInstSigTyVars, tcInstType, tcInstTheta + ) import Unify ( unifyTauTy ) @@ -54,29 +57,31 @@ import CmdLineOpts ( opt_GlasgowExts, opt_CompilingPrelude, opt_OmitDefaultInstanceMethods, opt_SpecialiseOverloaded ) import Class ( GenClass, GenClassOp, - isCcallishClass, getClassBigSig, - getClassOps, getClassOpLocalType ) -import CoreUtils ( escErrorMsg ) + isCcallishClass, classBigSig, + classOps, classOpLocalType, + classOpTagByString + ) import Id ( GenId, idType, isDefaultMethodId_maybe ) import ListSetOps ( minusList ) import Maybes ( maybeToBool, expectJust ) -import Name ( Name, getTagFromClassOpName ) -import Outputable -import PrelInfo ( pAT_ERROR_ID ) +import Name ( getLocalName, origName, nameOf ) +import PrelVals ( nO_EXPLICIT_METHOD_ERROR_ID ) +import PrelMods ( pRELUDE ) import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon, - pprParendType ) + pprParendGenType + ) import PprStyle import Pretty -import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) -import TyCon ( derivedFor ) +import RnUtils ( RnEnv(..) ) +import TyCon ( isSynTyCon, derivedFor ) import Type ( GenType(..), ThetaType(..), mkTyVarTys, splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy, - getTyCon_maybe, maybeBoxedPrimType ) + getTyCon_maybe, maybeBoxedPrimType + ) import TyVar ( GenTyVar, mkTyVarSet ) import TysWiredIn ( stringTy ) import Unique ( Unique ) import Util ( panic ) - \end{code} Typechecking instance declarations is done in two passes. The first @@ -155,14 +160,14 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm. \begin{code} tcInstDecls1 :: Bag RenamedInstDecl -> [RenamedSpecInstSig] - -> FAST_STRING -- module name for deriving - -> GlobalNameMappers -- renamer fns for deriving + -> Module -- module name for deriving + -> RnEnv -- for renaming derivings -> [RenamedFixityDecl] -- fixities for deriving -> TcM s (Bag InstInfo, RenamedHsBinds, PprStyle -> Pretty) -tcInstDecls1 inst_decls specinst_sigs mod_name renamer_name_funs fixities +tcInstDecls1 inst_decls specinst_sigs mod_name rn_env fixities = -- Do the ordinary instance declarations mapBagNF_Tc (tcInstDecl1 mod_name) inst_decls `thenNF_Tc` \ inst_info_bags -> @@ -173,7 +178,7 @@ tcInstDecls1 inst_decls specinst_sigs mod_name renamer_name_funs fixities -- for things in this module; we ignore deriving decls from -- interfaces! We pass fixities, because they may be used -- in deriving Read and Show. - tcDeriving mod_name renamer_name_funs decl_inst_info fixities + tcDeriving mod_name rn_env decl_inst_info fixities `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) -> let @@ -206,8 +211,11 @@ tcInstDecl1 mod_name -- Look things up tcLookupClass class_name `thenNF_Tc` \ (clas_kind, clas) -> + let + de_rn (RnName n) = n + in -- Typecheck the context and instance type - tcTyVarScope tyvar_names (\ tyvars -> + tcTyVarScope (map de_rn tyvar_names) (\ tyvars -> tcContext context `thenTc` \ theta -> tcMonoTypeKind inst_ty `thenTc` \ (tau_kind, tau) -> unifyKind clas_kind tau_kind `thenTc_` @@ -223,7 +231,9 @@ tcInstDecl1 mod_name if (not from_here && (clas `derivedFor` inst_tycon) && all isTyVarTy arg_tys) then - if mod_name == inst_mod then + if not opt_CompilingPrelude && maybeToBool inst_mod && + mod_name == expectJust "inst_mod" inst_mod + then -- Imported instance came from this module; -- discard and derive fresh instance returnTc emptyBag @@ -346,13 +356,11 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty tcAddSrcLoc locn $ -- Get the class signature - mapNF_Tc tcInstTyVar inst_tyvars `thenNF_Tc` \ inst_tyvars' -> + tcInstSigTyVars inst_tyvars `thenNF_Tc` \ (inst_tyvars', _, tenv) -> let - tenv = inst_tyvars `zip` (mkTyVarTys inst_tyvars') - (class_tyvar, super_classes, sc_sel_ids, - class_ops, op_sel_ids, defm_ids) = getClassBigSig clas + class_ops, op_sel_ids, defm_ids) = classBigSig clas in tcInstType tenv inst_ty `thenNF_Tc` \ inst_ty' -> tcInstTheta tenv dfun_theta `thenNF_Tc` \ dfun_theta' -> @@ -378,11 +386,11 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty mk_method_expr = if opt_OmitDefaultInstanceMethods then - makeInstanceDeclNoDefaultExpr origin clas meth_ids defm_ids inst_mod inst_ty' + makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty' clas inst_mod else - makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty' + makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id in - processInstBinds mk_method_expr inst_tyvars' avail_insts meth_ids monobinds + processInstBinds clas mk_method_expr inst_tyvars' avail_insts meth_ids monobinds `thenTc` \ (insts_needed, method_mbinds) -> let -- Create the dict and method binds @@ -483,7 +491,7 @@ newMethodId sel_id inst_ty origin loc tcInstType [(clas_tyvar,inst_ty)] (mkSigmaTy local_tyvars meth_theta sel_tau) `thenNF_Tc` \ method_ty -> - newLocalId (getOccurrenceName sel_id) method_ty `thenNF_Tc` \ meth_id -> + newLocalId (getLocalName sel_id) method_ty `thenNF_Tc` \ meth_id -> returnNF_Tc (emptyLIE, meth_id) \end{code} @@ -495,20 +503,18 @@ See the notes under default decls in TcClassDcl.lhs. \begin{code} makeInstanceDeclDefaultMethodExpr :: InstOrigin s - -> TcIdOcc s - -> [ClassOp] + -> [TcIdOcc s] -> [Id] -> TcType s + -> TcIdOcc s -> Int -> NF_TcM s (TcExpr s) -makeInstanceDeclDefaultMethodExpr origin this_dict class_ops defm_ids inst_ty tag - = specTy origin (getClassOpLocalType class_op) - `thenNF_Tc` \ (op_tyvars, op_lie, op_tau, op_dicts) -> +makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag + = newDicts origin op_theta `thenNF_Tc` \ (op_lie,op_dicts) -> -- def_op_id = /\ op_tyvars -> \ op_dicts -> -- defm_id inst_ty op_tyvars this_dict op_dicts - returnNF_Tc ( mkHsTyLam op_tyvars ( mkHsDictLam op_dicts ( @@ -517,25 +523,23 @@ makeInstanceDeclDefaultMethodExpr origin this_dict class_ops defm_ids inst_ty ta (this_dict : op_dicts) ))) where - idx = tag - 1 - class_op = class_ops !! idx - defm_id = defm_ids !! idx + idx = tag - 1 + meth_id = meth_ids !! idx + defm_id = defm_ids !! idx + (op_tyvars, op_theta, op_tau) = splitSigmaTy (tcIdType meth_id) makeInstanceDeclNoDefaultExpr :: InstOrigin s - -> Class -> [TcIdOcc s] -> [Id] - -> FAST_STRING -> TcType s + -> Class + -> Maybe Module -> Int -> NF_TcM s (TcExpr s) -makeInstanceDeclNoDefaultExpr origin clas method_occs defm_ids inst_mod inst_ty tag - = let - (op_tyvars,op_theta,op_tau) = splitSigmaTy (idType method_id) - in - newDicts origin op_theta `thenNF_Tc` \ (op_lie,op_dicts) -> +makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag + = newDicts origin op_theta `thenNF_Tc` \ (op_lie, op_dicts) -> -- Produce a warning if the default instance method -- has been omitted when one exists in the class @@ -544,25 +548,24 @@ makeInstanceDeclNoDefaultExpr origin clas method_occs defm_ids inst_mod inst_ty `thenNF_Tc_` returnNF_Tc (mkHsTyLam op_tyvars ( mkHsDictLam op_dicts ( - HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [op_tau]) + HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [op_tau]) (HsLitOut (HsString (_PK_ error_msg)) stringTy)))) where - idx = tag - 1 - method_occ = method_occs !! idx - clas_op = (getClassOps clas) !! idx - defm_id = defm_ids !! idx + idx = tag - 1 + meth_id = meth_ids !! idx + clas_op = (classOps clas) !! idx + defm_id = defm_ids !! idx + (op_tyvars,op_theta,op_tau) = splitSigmaTy (tcIdType meth_id) - TcId method_id = method_occ Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id - error_msg = "%E" -- => No explicit method for \" - ++ escErrorMsg error_str + mod_str = case inst_mod of { Nothing -> pRELUDE; Just m -> m } - error_str = _UNPK_ inst_mod ++ "." ++ _UNPK_ clas_name ++ "." + error_msg = _UNPK_ mod_str ++ "." ++ _UNPK_ clas_name ++ "." ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "." ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\"" - (_, clas_name) = getOrigName clas + clas_name = nameOf (origName clas) \end{code} @@ -584,7 +587,8 @@ do differs between instance and class decls. \begin{code} processInstBinds - :: (Int -> NF_TcM s (TcExpr s)) -- Function to make default method + :: Class + -> (Int -> NF_TcM s (TcExpr s)) -- Function to make default method -> [TcTyVar s] -- Tyvars for this instance decl -> LIE s -- available Insts -> [TcIdOcc s] -- Local method ids in tag order @@ -593,10 +597,10 @@ processInstBinds -> TcM s (LIE s, -- These are required TcMonoBinds s) -processInstBinds mk_default_method_rhs inst_tyvars avail_insts method_ids monobinds +processInstBinds clas mk_default_method_rhs inst_tyvars avail_insts method_ids monobinds = -- Process the explicitly-given method bindings - processInstBinds1 inst_tyvars avail_insts method_ids monobinds + processInstBinds1 clas inst_tyvars avail_insts method_ids monobinds `thenTc` \ (tags, insts_needed_in_methods, method_binds) -> -- Find the methods not handled, and make default method bindings for them. @@ -617,7 +621,8 @@ processInstBinds mk_default_method_rhs inst_tyvars avail_insts method_ids monobi \begin{code} processInstBinds1 - :: [TcTyVar s] -- Tyvars for this instance decl + :: Class + -> [TcTyVar s] -- Tyvars for this instance decl -> LIE s -- available Insts -> [TcIdOcc s] -- Local method ids in tag order (instance tyvars are free), -> RenamedMonoBinds @@ -625,13 +630,13 @@ processInstBinds1 LIE s, -- These are required TcMonoBinds s) -processInstBinds1 inst_tyvars avail_insts method_ids EmptyMonoBinds +processInstBinds1 clas inst_tyvars avail_insts method_ids EmptyMonoBinds = returnTc ([], emptyLIE, EmptyMonoBinds) -processInstBinds1 inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2) - = processInstBinds1 inst_tyvars avail_insts method_ids mb1 +processInstBinds1 clas inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2) + = processInstBinds1 clas inst_tyvars avail_insts method_ids mb1 `thenTc` \ (op_tags1,dicts1,method_binds1) -> - processInstBinds1 inst_tyvars avail_insts method_ids mb2 + processInstBinds1 clas inst_tyvars avail_insts method_ids mb2 `thenTc` \ (op_tags2,dicts2,method_binds2) -> returnTc (op_tags1 ++ op_tags2, dicts1 `unionBags` dicts2, @@ -639,7 +644,7 @@ processInstBinds1 inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2) \end{code} \begin{code} -processInstBinds1 inst_tyvars avail_insts method_ids mbind +processInstBinds1 clas inst_tyvars avail_insts method_ids mbind = -- Find what class op is being defined here. The complication is -- that we could have a PatMonoBind or a FunMonoBind. If the @@ -649,20 +654,20 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind -- Renamer has reduced us to these two cases. let (op,locn) = case mbind of - FunMonoBind op _ locn -> (op, locn) + FunMonoBind op _ _ locn -> (op, locn) PatMonoBind (VarPatIn op) _ locn -> (op, locn) - occ = getOccurrenceName op + occ = getLocalName op origin = InstanceDeclOrigin in tcAddSrcLoc locn $ -- Make a method id for the method - let tag = getTagFromClassOpName op + let + tag = classOpTagByString clas occ method_id = method_ids !! (tag-1) - TcId method_bndr = method_id - method_ty = idType method_bndr + method_ty = tcIdType method_id (method_tyvars, method_theta, method_tau) = splitSigmaTy method_ty in newDicts origin method_theta `thenNF_Tc` \ (method_dicts,method_dict_ids) -> @@ -673,12 +678,6 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind -- Type check the method itself tcMethodBind method_id method_tau mbind `thenTc` \ (mbind', lieIop) -> - - -- Make sure that the instance tyvars havn't been - -- unified with each other or with the method tyvars. - tcSetErrCtxt (methodSigCtxt op method_tau) ( - checkSigTyVars inst_tyvars method_tau method_tau - ) `thenTc_` returnTc ([tag], lieIop, mbind') other -> -- It's a locally-polymorphic and/or overloaded method; UGH! @@ -696,12 +695,6 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind -- Typecheck the method tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) -> - -- Make sure that the instance tyvars haven't been - -- unified with each other or with the method tyvars. - tcAddErrCtxt (methodSigCtxt op method_tau) ( - checkSigTyVars inst_method_tyvars method_tau method_tau - ) `thenTc_` - -- Check the overloading part of the signature. -- Simplify everything fully, even though some -- constraints could "really" be left to the next @@ -735,9 +728,9 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind tcMethodBind :: TcIdOcc s -> TcType s -> RenamedMonoBinds -> TcM s (TcMonoBinds s, LIE s) -tcMethodBind meth_id meth_ty (FunMonoBind name matches locn) +tcMethodBind meth_id meth_ty (FunMonoBind name inf matches locn) = tcMatchesFun name meth_ty matches `thenTc` \ (rhs', lie) -> - returnTc (FunMonoBind meth_id rhs' locn, lie) + returnTc (FunMonoBind meth_id inf rhs' locn, lie) tcMethodBind meth_id meth_ty pbind@(PatMonoBind pat grhss_and_binds locn) -- pat is sure to be a (VarPatIn op) @@ -789,7 +782,7 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc clas = lookupCE ce class_name -- Renamer ensures this can't fail -- Make some new type variables, named as in the specialised instance type - ty_names = extractMonoTyNames (==) ty + ty_names = extractMonoTyNames ???is_tyvarish_name??? ty (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names in babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty) @@ -839,12 +832,12 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta, if null simpl_theta then ppNil else ppStr "=>", ppr PprDebug clas, - pprParendType PprDebug inst_ty], + pprParendGenType PprDebug inst_ty], ppCat [ppStr " derived from:", if null unspec_theta then ppNil else ppr PprDebug unspec_theta, if null unspec_theta then ppNil else ppStr "=>", ppr PprDebug clas, - pprParendType PprDebug unspec_inst_ty]]) + pprParendGenType PprDebug unspec_inst_ty]]) else id) ( returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta @@ -897,7 +890,7 @@ We can also have instances for functions: @instance Foo (a -> b) ...@. \begin{code} scrutiniseInstanceType from_here clas inst_tau -- TYCON CHECK - | not (maybeToBool inst_tycon_maybe) + | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon = failTc (instTypeErr inst_tau) -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1) @@ -920,7 +913,7 @@ scrutiniseInstanceType from_here clas inst_tau = failTc (derivingWhenInstanceExistsErr clas inst_tycon) | -- CCALL CHECK - -- A user declaration of a _CCallable/_CReturnable instance + -- A user declaration of a CCallable/CReturnable instance -- must be for a "boxed primitive" type. isCcallishClass clas && not opt_CompilingPrelude -- which allows anything @@ -952,7 +945,11 @@ derivingWhenInstanceExistsErr clas tycon sty derivingWhenInstanceImportedErr inst_mod clas tycon sty = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"]) - 4 (ppBesides [ppStr "when an instance declared in module `", ppPStr inst_mod, ppStr "' has been imported"]) + 4 (ppBesides [ppStr "when an instance declared in module `", pp_mod, ppStr "' has been imported"]) + where + pp_mod = case inst_mod of + Nothing -> ppPStr SLIT("the standard Prelude") + Just m -> ppBesides [ppStr "module `", ppPStr m, ppStr "'"] nonBoxedPrimCCallErr clas inst_ty sty = ppHang (ppStr "Instance isn't for a `boxed-primitive' type") @@ -962,7 +959,7 @@ nonBoxedPrimCCallErr clas inst_ty sty omitDefaultMethodWarn clas_op clas_name inst_ty sty = ppCat [ppStr "Warning: Omitted default method for", ppr sty clas_op, ppStr "in instance", - ppPStr clas_name, pprParendType sty inst_ty] + ppPStr clas_name, pprParendGenType sty inst_ty] patMonoBindsCtxt pbind sty