X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=df32170f2bcc104b95fee0535bc6c85315c9afe9;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=80238ffce9dadc405be5066a68465a1118c76509;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 80238ff..df32170 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -9,8 +9,7 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2, - processInstBinds, - newMethodId + processInstBinds ) where @@ -20,33 +19,34 @@ 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(..), RnName(..){-incl instance Outputable-} ) -import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), - TcMonoBinds(..), TcExpr(..), tcIdType, +import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds), + SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType, mkHsTyLam, mkHsTyApp, mkHsDictLam, mkHsDictApp ) import TcMonad hiding ( rnMtoTcM ) -import GenSpecEtc ( checkSigTyVarsGivenGlobals ) -import Inst ( Inst, InstOrigin(..), InstanceMapper(..), - newDicts, newMethod, LIE(..), emptyLIE, plusLIE ) +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 ) -import TcType ( TcType(..), TcTyVar(..), +import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType ) import Unify ( unifyTauTy, unifyTauTyLists ) @@ -54,9 +54,10 @@ 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, classBigSig, classOps, classOpLocalType, @@ -73,13 +74,13 @@ import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon, ) import PprStyle import Pretty -import RnUtils ( RnEnv(..) ) +import RnUtils ( SYN_IE(RnEnv) ) import TyCon ( isSynTyCon, derivedFor ) -import Type ( GenType(..), ThetaType(..), mkTyVarTys, +import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys, splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy, - getTyCon_maybe, maybeBoxedPrimType, splitRhoTy + getTyCon_maybe, maybeBoxedPrimType, splitRhoTy, eqTy ) -import TyVar ( GenTyVar, mkTyVarSet, unionTyVarSets ) +import TyVar ( GenTyVar, SYN_IE(GenTyVarSet), mkTyVarSet, unionTyVarSets ) import TysWiredIn ( stringTy ) import Unique ( Unique ) import Util ( zipEqual, panic ) @@ -232,8 +233,7 @@ tcInstDecl1 mod_name if (not from_here && (clas `derivedFor` inst_tycon) && all isTyVarTy arg_tys) then - if not opt_CompilingPrelude && maybeToBool inst_mod && - mod_name == expectJust "inst_mod" inst_mod + if mod_name == inst_mod then -- Imported instance came from this module; -- discard and derive fresh instance @@ -369,7 +369,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty let sc_theta' = super_classes `zip` repeat inst_ty' origin = InstanceDeclOrigin - mk_method sel_id = newMethodId sel_id inst_ty' origin + 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) -> @@ -382,6 +382,8 @@ 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) @@ -391,8 +393,9 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty else makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id in - processInstBinds clas 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 @@ -401,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) ( @@ -448,62 +450,6 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty returnTc (const_lie `plusLIE` spec_lie, inst_binds) \end{code} -============= OLD ================ - -@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. -=============== END OF OLD =================== - -\begin{code} -newMethodId sel_id inst_ty origin - = newMethod origin (RealId sel_id) [inst_ty] - - -{- REMOVE SOON: (this was pre-split-poly selector types) -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 (getLocalName 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. @@ -534,7 +480,7 @@ makeInstanceDeclNoDefaultExpr -> [Id] -> TcType s -> Class - -> Maybe Module + -> Module -> Int -> NF_TcM s (TcExpr s) @@ -555,13 +501,11 @@ makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id - mod_str = case inst_mod of { Nothing -> pRELUDE; Just m -> m } - - error_msg = _UNPK_ mod_str ++ "." ++ _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 = nameOf (origName clas) + clas_name = nameOf (origName "makeInstanceDeclNoDefaultExpr" clas) \end{code} @@ -585,7 +529,6 @@ do differs between instance and class decls. processInstBinds :: 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 -- (instance tyvars are free in their types) @@ -593,10 +536,10 @@ processInstBinds -> TcM s (LIE s, -- These are required TcMonoBinds s) -processInstBinds clas 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 clas 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. @@ -618,7 +561,6 @@ processInstBinds clas mk_default_method_rhs inst_tyvars avail_insts method_ids m \begin{code} processInstBinds1 :: 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 @@ -626,13 +568,13 @@ processInstBinds1 LIE s, -- These are required TcMonoBinds s) -processInstBinds1 clas inst_tyvars avail_insts method_ids EmptyMonoBinds +processInstBinds1 clas avail_insts method_ids EmptyMonoBinds = returnTc ([], emptyLIE, EmptyMonoBinds) -processInstBinds1 clas inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2) - = processInstBinds1 clas 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 clas 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, @@ -640,7 +582,7 @@ processInstBinds1 clas inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2) \end{code} \begin{code} -processInstBinds1 clas 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 @@ -690,18 +632,19 @@ processInstBinds1 clas inst_tyvars avail_insts method_ids mbind -- 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 (mkTyVarTys method_tyvars) sig_tyvar_tys `thenTc_` + 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_tyvar_set = mkTyVarSet inst_tyvars - inst_method_tyvar_set = inst_tyvar_set `unionTyVarSets` (mkTyVarSet sig_tyvars) + sig_tyvar_set = mkTyVarSet sig_tyvars in -- Typecheck the method tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) -> -- 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 @@ -710,13 +653,18 @@ processInstBinds1 clas 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) ( - checkSigTyVarsGivenGlobals - inst_tyvar_set + checkSigTyVars sig_tyvars method_tau `thenTc_` tcSimplifyAndCheck - inst_method_tyvar_set + sig_tyvar_set (method_dicts `plusLIE` avail_insts) lieIop ) `thenTc` \ (f_dicts, dict_binds) -> @@ -908,12 +856,11 @@ scrutiniseInstanceType from_here clas inst_tau = 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) @@ -930,8 +877,9 @@ scrutiniseInstanceType from_here clas inst_tau -- A user declaration of a CCallable/CReturnable instance -- must be for a "boxed primitive" type. isCcallishClass clas --- && not opt_CompilingPrelude -- which allows anything - && not (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 @@ -961,9 +909,7 @@ 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 `", 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 "'"] + pp_mod = ppBesides [ppStr "module `", ppPStr inst_mod, ppStr "'"] nonBoxedPrimCCallErr clas inst_ty sty = ppHang (ppStr "Instance isn't for a `boxed-primitive' type")