X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=df32170f2bcc104b95fee0535bc6c85315c9afe9;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=e910658c126ce147afac880a330dcad56fbb6462;hpb=4250d64191132fd493985549eda5ca05b82a663f;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index e910658..df32170 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -13,73 +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(..), 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 +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, 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 ( getLocalName, origName, nameOf ) -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, pprParendGenType ) import PprStyle import Pretty -import RnUtils ( RnEnv(..) ) -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 @@ -229,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 @@ -242,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) -> @@ -358,15 +361,15 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty let (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) -> @@ -379,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) @@ -388,8 +393,9 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty else 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 @@ -398,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) ( @@ -433,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) @@ -445,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. @@ -509,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 @@ -532,41 +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 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 meth_id = meth_ids !! idx - clas_op = (getClassOps clas) !! 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 - error_msg = "%E" -- => No explicit method for \" - ++ escErrorMsg error_str - - mod_str = case inst_mod of { Nothing -> pRELUDE; Just m -> m } - - error_str = _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} @@ -588,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) @@ -597,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. @@ -621,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 @@ -629,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, @@ -643,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 @@ -662,13 +601,17 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind tcAddSrcLoc locn $ -- Make a method id for the method - let tag = panic "processInstBinds1:getTagFromClassOpName"{-getTagFromClassOpName op-} + 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 @@ -685,15 +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) -> -- 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 @@ -702,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 @@ -811,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) -> @@ -888,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) @@ -914,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 @@ -945,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")