X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=df32170f2bcc104b95fee0535bc6c85315c9afe9;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=6e3db5bc9d45720ce7ba62aff1d7383002ab3a9c;hpb=0596517a9b4b2b32e5d375a986351102ac4540fc;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 6e3db5b..df32170 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -13,70 +13,77 @@ module TcInstDcls ( ) where -import Ubiq +IMP_Ubiq() import HsSyn ( InstDecl(..), FixityDecl, Sig(..), SpecInstSig(..), HsBinds(..), Bind(..), MonoBinds(..), GRHSsAndBinds, Match, InPat(..), OutPat(..), HsExpr(..), HsLit(..), - Stmt, Qual, ArithSeqInfo, Fake, + Stmt, Qualifier, ArithSeqInfo, Fake, PolyType(..), MonoType ) -import RnHsSyn ( RenamedHsBinds(..), RenamedMonoBinds(..), +import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds), RenamedInstDecl(..), RenamedFixityDecl(..), - RenamedSig(..), RenamedSpecInstSig(..) ) -import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), - TcMonoBinds(..), TcExpr(..), + RenamedSig(..), RenamedSpecInstSig(..), + RnName(..){-incl instance Outputable-} + ) +import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds), + SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType, mkHsTyLam, mkHsTyApp, mkHsDictLam, mkHsDictApp ) -import TcMonad -import GenSpecEtc ( checkSigTyVars, specTy ) -import Inst ( Inst, InstOrigin(..), InstanceMapper(..), - newDicts, newMethod, LIE(..), emptyLIE, plusLIE ) +import TcMonad hiding ( rnMtoTcM ) +import GenSpecEtc ( checkSigTyVars ) +import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper), + newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE ) import TcBinds ( tcPragmaSigs ) import TcDeriv ( tcDeriving ) -import TcEnv ( tcLookupClass, tcTyVarScope, newLocalId ) +import TcEnv ( tcLookupClass, tcTyVarScope, newLocalId, tcExtendGlobalTyVars ) +import SpecEnv ( SpecEnv ) import TcGRHSs ( tcGRHSsAndBinds ) import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs ) import TcKind ( TcKind, unifyKind ) import TcMatches ( tcMatchesFun ) import TcMonoType ( tcContext, tcMonoTypeKind ) -import TcSimplify ( tcSimplifyAndCheck, tcSimplifyThetas ) -import TcType ( TcType(..), TcTyVar(..), - tcInstTyVar, tcInstType, tcInstTheta ) -import Unify ( unifyTauTy ) +import TcSimplify ( tcSimplifyAndCheck ) +import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), + tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType + ) +import Unify ( unifyTauTy, unifyTauTyLists ) import Bag ( emptyBag, unitBag, unionBags, unionManyBags, concatBag, foldBag, bagToList ) -import CmdLineOpts ( opt_GlasgowExts, opt_CompilingPrelude, +import CmdLineOpts ( opt_GlasgowExts, opt_CompilingGhcInternals, opt_OmitDefaultInstanceMethods, - opt_SpecialiseOverloaded ) + 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, Name{--O only-} ) +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 Type ( GenType(..), ThetaType(..), mkTyVarTys, +import RnUtils ( SYN_IE(RnEnv) ) +import TyCon ( isSynTyCon, derivedFor ) +import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys, splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy, - getTyCon_maybe, maybeBoxedPrimType ) -import TyVar ( GenTyVar, mkTyVarSet ) + getTyCon_maybe, maybeBoxedPrimType, splitRhoTy, eqTy + ) +import TyVar ( GenTyVar, SYN_IE(GenTyVarSet), mkTyVarSet, unionTyVarSets ) import TysWiredIn ( stringTy ) import Unique ( Unique ) -import Util ( panic ) - +import Util ( zipEqual, panic ) \end{code} Typechecking instance declarations is done in two passes. The first @@ -155,14 +162,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 +180,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 +213,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 +233,8 @@ tcInstDecl1 mod_name if (not from_here && (clas `derivedFor` inst_tycon) && all isTyVarTy arg_tys) then - if mod_name == inst_mod then + if mod_name == inst_mod + then -- Imported instance came from this module; -- discard and derive fresh instance returnTc emptyBag @@ -234,7 +245,7 @@ tcInstDecl1 mod_name else -- Make the dfun id and constant-method ids - mkInstanceRelatedIds from_here inst_mod pragmas + mkInstanceRelatedIds from_here src_loc inst_mod pragmas clas inst_tyvars inst_tau inst_theta uprags `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) -> @@ -346,21 +357,19 @@ 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' -> tcInstTheta tenv inst_decl_theta `thenNF_Tc` \ inst_decl_theta' -> let - sc_theta' = super_classes `zip` (repeat inst_ty') + sc_theta' = super_classes `zip` repeat inst_ty' origin = InstanceDeclOrigin - mk_method sel_id = newMethodId sel_id inst_ty' origin locn + mk_method sel_id = newMethod origin (RealId sel_id) [inst_ty'] in -- Create dictionary Ids from the specified instance contexts. newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) -> @@ -373,17 +382,20 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty -- Collect available Insts let + inst_tyvars_set' = mkTyVarSet inst_tyvars' + avail_insts -- These insts are in scope; quite a few, eh? = unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s) 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 - `thenTc` \ (insts_needed, method_mbinds) -> + tcExtendGlobalTyVars inst_tyvars_set' ( + processInstBinds clas mk_method_expr avail_insts meth_ids monobinds + ) `thenTc` \ (insts_needed, method_mbinds) -> let -- Create the dict and method binds dict_bind @@ -392,7 +404,6 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty dict_and_method_binds = dict_bind `AndMonoBinds` method_mbinds - inst_tyvars_set' = mkTyVarSet inst_tyvars' in -- Check the overloading constraints of the methods and superclasses tcAddErrCtxt (bindSigCtxt meth_ids) ( @@ -427,8 +438,8 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty inst_tyvars' dfun_arg_dicts_ids ((this_dict_id, RealId dfun_id) - : (meth_ids `zip` (map RealId const_meth_ids))) - -- const_meth_ids will often be empty + : (meth_ids `zip` map RealId const_meth_ids)) + -- NB: const_meth_ids will often be empty super_binds (RecBind dict_and_method_binds) @@ -439,54 +450,6 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty returnTc (const_lie `plusLIE` spec_lie, inst_binds) \end{code} -@mkMethodId@ manufactures an id for a local method. -It's rather turgid stuff, because there are two cases: - - (a) For methods with no local polymorphism, we can make an Inst of the - class-op selector function and a corresp InstId; - which is good because then other methods which call - this one will do so directly. - - (b) For methods with local polymorphism, we can't do this. For example, - - class Foo a where - op :: (Num b) => a -> b -> a - - Here the type of the class-op-selector is - - forall a b. (Foo a, Num b) => a -> b -> a - - The locally defined method at (say) type Float will have type - - forall b. (Num b) => Float -> b -> Float - - and the one is not an instance of the other. - - So for these we just make a local (non-Inst) id with a suitable type. - -How disgusting. - -\begin{code} -newMethodId sel_id inst_ty origin loc - = let (sel_tyvars,sel_theta,sel_tau) = splitSigmaTy (idType sel_id) - (_:meth_theta) = sel_theta -- The local theta is all except the - -- first element of the context - in - case sel_tyvars of - -- Ah! a selector for a class op with no local polymorphism - -- Build an Inst for this - [clas_tyvar] -> newMethod origin (RealId sel_id) [inst_ty] - - -- Ho! a selector for a class op with local polymorphism. - -- Just make a suitably typed local id for this - (clas_tyvar:local_tyvars) -> - 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 -> - returnNF_Tc (emptyLIE, meth_id) -\end{code} - The next function makes a default method which calls the global default method, at the appropriate instance type. @@ -495,74 +458,54 @@ 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) -> - - -- 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 ( - mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) - (inst_ty : mkTyVarTys op_tyvars)) - (this_dict : op_dicts) - ))) +makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag + = + -- def_op_id = defm_id inst_ty this_dict + returnNF_Tc (mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) [inst_ty]) [this_dict]) 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 makeInstanceDeclNoDefaultExpr :: InstOrigin s - -> Class -> [TcIdOcc s] -> [Id] - -> FAST_STRING -> TcType s + -> Class + -> 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 + = -- Produce a warning if the default instance method -- has been omitted when one exists in the class warnTc (not err_defm_ok) (omitDefaultMethodWarn clas_op clas_name inst_ty) `thenNF_Tc_` - returnNF_Tc (mkHsTyLam op_tyvars ( - mkHsDictLam op_dicts ( - HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [op_tau]) - (HsLitOut (HsString (_PK_ error_msg)) stringTy)))) + returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [tcIdType meth_id]) + (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 - TcId method_id = method_occ Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id - error_msg = "%E" -- => No explicit method for \" - ++ escErrorMsg error_str - - error_str = _UNPK_ inst_mod ++ "." ++ _UNPK_ clas_name ++ "." + error_msg = _UNPK_ inst_mod ++ "." ++ _UNPK_ clas_name ++ "." ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "." ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\"" - (_, clas_name) = getOrigName clas + clas_name = nameOf (origName "makeInstanceDeclNoDefaultExpr" clas) \end{code} @@ -584,8 +527,8 @@ do differs between instance and class decls. \begin{code} processInstBinds - :: (Int -> NF_TcM s (TcExpr s)) -- Function to make default method - -> [TcTyVar s] -- Tyvars for this instance decl + :: Class + -> (Int -> NF_TcM s (TcExpr s)) -- Function to make default method -> LIE s -- available Insts -> [TcIdOcc s] -- Local method ids in tag order -- (instance tyvars are free in their types) @@ -593,10 +536,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 avail_insts method_ids monobinds = -- Process the explicitly-given method bindings - processInstBinds1 inst_tyvars avail_insts method_ids monobinds + processInstBinds1 clas 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 +560,7 @@ processInstBinds mk_default_method_rhs inst_tyvars avail_insts method_ids monobi \begin{code} processInstBinds1 - :: [TcTyVar s] -- Tyvars for this instance decl + :: Class -> LIE s -- available Insts -> [TcIdOcc s] -- Local method ids in tag order (instance tyvars are free), -> RenamedMonoBinds @@ -625,13 +568,13 @@ processInstBinds1 LIE s, -- These are required TcMonoBinds s) -processInstBinds1 inst_tyvars avail_insts method_ids EmptyMonoBinds +processInstBinds1 clas 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 avail_insts method_ids (AndMonoBinds mb1 mb2) + = processInstBinds1 clas avail_insts method_ids mb1 `thenTc` \ (op_tags1,dicts1,method_binds1) -> - processInstBinds1 inst_tyvars avail_insts method_ids mb2 + processInstBinds1 clas avail_insts method_ids mb2 `thenTc` \ (op_tags2,dicts2,method_binds2) -> returnTc (op_tags1 ++ op_tags2, dicts1 `unionBags` dicts2, @@ -639,7 +582,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 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,23 +592,26 @@ 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) + method_ty = tcIdType method_id + in - TcId method_bndr = method_id - method_ty = idType method_bndr - (method_tyvars, method_theta, method_tau) = splitSigmaTy method_ty + tcInstTcType method_ty `thenNF_Tc` \ (method_tyvars, method_rho) -> + let + (method_theta, method_tau) = splitRhoTy method_rho in - newDicts origin method_theta `thenNF_Tc` \ (method_dicts,method_dict_ids) -> + newDicts origin method_theta `thenNF_Tc` \ (method_dicts,method_dict_ids) -> case (method_tyvars, method_dict_ids) of @@ -673,12 +619,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! @@ -688,21 +628,23 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind -- The latter is needed just so we can return an AbsBinds wrapped -- up inside a MonoBinds. + + -- Make the method_tyvars into signature tyvars so they + -- won't get unified with anything. + tcInstSigTyVars method_tyvars `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) -> + unifyTauTyLists sig_tyvar_tys (mkTyVarTys method_tyvars) `thenTc_` + newLocalId occ method_tau `thenNF_Tc` \ local_id -> newLocalId occ method_ty `thenNF_Tc` \ copy_id -> let - inst_method_tyvars = inst_tyvars ++ method_tyvars + sig_tyvar_set = mkTyVarSet sig_tyvars in -- 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. + + -- =========== POSSIBLE BUT NOT DONE ================= -- Simplify everything fully, even though some -- constraints could "really" be left to the next -- level out. The case which forces this is @@ -711,13 +653,23 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind -- -- Here we must simplify constraints on "a" to catch all -- the Bar-ish things. + + -- We don't do this because it's currently illegal Haskell (not sure why), + -- and because the local type of the method would have a context at + -- the front with no for-all, which confuses the hell out of everything! + -- ==================================================== + tcAddErrCtxt (methodSigCtxt op method_ty) ( + checkSigTyVars + sig_tyvars method_tau `thenTc_` + tcSimplifyAndCheck - (mkTyVarSet inst_method_tyvars) + sig_tyvar_set (method_dicts `plusLIE` avail_insts) lieIop ) `thenTc` \ (f_dicts, dict_binds) -> + returnTc ([tag], f_dicts, VarMonoBind method_id @@ -735,9 +687,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 +741,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) @@ -820,16 +772,19 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc mk_spec_origin clas ty = InstanceSpecOrigin inst_mapper clas ty src_loc + -- I'm VERY SUSPICIOUS ABOUT THIS + -- the inst-mapper is in a knot at this point so it's no good + -- looking at it in tcSimplify... in tcSimplifyThetas mk_spec_origin subst_tv_theta `thenTc` \ simpl_tv_theta -> let simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ] - tv_tmpl_map = inst_tv_tys `zipEqual` inst_tmpl_tys + tv_tmpl_map = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv in - mkInstanceRelatedIds e True{-from here-} mod NoInstancePragmas src_loc + mkInstanceRelatedIds e True{-from here-} src_loc mod NoInstancePragmas clas inst_tmpls inst_ty simpl_theta uprag `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) -> @@ -839,12 +794,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,16 +852,15 @@ 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) - | from_here + | not from_here = returnTc (inst_tycon,arg_tys) -- TYVARS CHECK | not (all isTyVarTy arg_tys || - not from_here || opt_GlasgowExts) = failTc (instTypeErr inst_tau) @@ -920,11 +874,12 @@ 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 - && maybeToBool (maybeBoxedPrimType inst_tau) + && not (maybeToBool (maybeBoxedPrimType inst_tau) + || opt_CompilingGhcInternals) -- this lets us get up to mischief; + -- e.g., instance CCallable () = failTc (nonBoxedPrimCCallErr clas inst_tau) | otherwise @@ -952,7 +907,9 @@ 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 = ppBesides [ppStr "module `", ppPStr inst_mod, ppStr "'"] nonBoxedPrimCCallErr clas inst_ty sty = ppHang (ppStr "Instance isn't for a `boxed-primitive' type") @@ -962,7 +919,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