X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=df32170f2bcc104b95fee0535bc6c85315c9afe9;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=238e3fd58a17971cb499d6f67f5d8fab4149361f;hpb=ca5a4a480d10d61e5b7a52eb4d556e8b8c33e69d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 238e3fd..df32170 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -13,49 +13,51 @@ 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(..), 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 ( checkSigTyVars ) -import Inst ( Inst, InstOrigin(..), InstanceMapper(..), - newDicts, newMethod, LIE(..), emptyLIE, plusLIE ) +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(..), - tcInstSigTyVars, tcInstType, tcInstTheta +import TcSimplify ( tcSimplifyAndCheck ) +import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), + tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType ) -import Unify ( unifyTauTy ) +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, @@ -72,16 +74,16 @@ 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 + getTyCon_maybe, maybeBoxedPrimType, splitRhoTy, eqTy ) -import TyVar ( GenTyVar, mkTyVarSet ) +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 @@ -231,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 @@ -244,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) -> @@ -366,9 +367,9 @@ tcInstDecl2 (InstInfo clas inst_tyvars 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) -> @@ -381,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) @@ -390,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 @@ -400,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) ( @@ -435,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) @@ -447,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 (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. @@ -511,22 +466,13 @@ makeInstanceDeclDefaultMethodExpr -> NF_TcM s (TcExpr s) 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 ( - mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) - (inst_ty : mkTyVarTys op_tyvars)) - (this_dict : op_dicts) - ))) + = + -- 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 meth_id = meth_ids !! idx defm_id = defm_ids !! idx - (op_tyvars, op_theta, op_tau) = splitSigmaTy (tcIdType meth_id) makeInstanceDeclNoDefaultExpr :: InstOrigin s @@ -534,38 +480,32 @@ makeInstanceDeclNoDefaultExpr -> [Id] -> TcType s -> Class - -> Maybe Module + -> Module -> Int -> NF_TcM s (TcExpr s) 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 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 nO_EXPLICIT_METHOD_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 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) 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} @@ -589,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) @@ -597,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. @@ -622,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 @@ -630,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, @@ -644,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 @@ -666,11 +604,14 @@ processInstBinds1 clas inst_tyvars avail_insts method_ids mbind let tag = classOpTagByString clas occ method_id = method_ids !! (tag-1) - 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) -> + + 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) -> case (method_tyvars, method_dict_ids) of @@ -687,15 +628,23 @@ processInstBinds1 clas 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) -> -- 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 @@ -704,13 +653,23 @@ 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) ( + 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 @@ -813,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) -> @@ -894,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) @@ -916,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 - && 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 @@ -947,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")