X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=3b9a49646ea6a5528bd1a48a1949c95d8984e61b;hp=bf9d9229087dfff49405944de03feea7eda61e8c;hb=79011516105291b58324ce71a87f6bb26a131090;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index bf9d922..3b9a496 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -5,11 +5,11 @@ \section[TcBinds]{TcBinds} \begin{code} -{-# OPTIONS_GHC -w #-} +{-# OPTIONS -w #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details module TcBinds ( tcLocalBinds, tcTopBinds, @@ -18,8 +18,6 @@ module TcBinds ( tcLocalBinds, tcTopBinds, TcSigInfo(..), TcSigFun, mkTcSigFun, badBootDeclErr ) where -#include "HsVersions.h" - import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) @@ -42,7 +40,7 @@ import VarEnv import TysPrim import Id import IdInfo -import Var ( TyVar ) +import Var ( TyVar, varType ) import Name import NameSet import NameEnv @@ -56,6 +54,9 @@ import List import Util import BasicTypes import Outputable +import FastString + +import Control.Monad \end{code} @@ -115,7 +116,7 @@ tcHsBootSigs (ValBindsOut binds sigs) tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups) badBootDeclErr :: Message -badBootDeclErr = ptext SLIT("Illegal declarations in an hs-boot file") +badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file") ------------------------ tcLocalBinds :: HsLocalBinds Name -> TcM thing @@ -141,11 +142,11 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside -- I wonder if we should do these one at at time -- Consider ?x = 4 -- ?y = ?x + 1 - tc_ip_bind (IPBind ip expr) - = newFlexiTyVarTy argTypeKind `thenM` \ ty -> - newIPDict (IPBindOrigin ip) ip ty `thenM` \ (ip', ip_inst) -> - tcMonoExpr expr ty `thenM` \ expr' -> - returnM (ip_inst, (IPBind ip' expr')) + tc_ip_bind (IPBind ip expr) = do + ty <- newFlexiTyVarTy argTypeKind + (ip', ip_inst) <- newIPDict (IPBindOrigin ip) ip ty + expr' <- tcMonoExpr expr ty + return (ip_inst, (IPBind ip' expr')) ------------------------ tcValBinds :: TopLevelFlag @@ -313,8 +314,8 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds setSrcSpan loc $ recoverM (recoveryCode binder_names sig_fn) $ do - { traceTc (ptext SLIT("------------------------------------------------")) - ; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names) + { traceTc (ptext (sLit "------------------------------------------------")) + ; traceTc (ptext (sLit "Bindings for") <+> ppr binder_names) -- TYPECHECK THE BINDINGS ; ((binds', mono_bind_infos), lie_req) @@ -344,15 +345,15 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds generalise dflags top_lvl bind_list sig_fn mono_bind_infos lie_req -- BUILD THE POLYMORPHIC RESULT IDs - ; let dict_ids = map instToId dicts - ; exports <- mapM (mkExport top_lvl prag_fn tyvars_to_gen (map idType dict_ids)) + ; let dict_vars = map instToVar dicts -- May include equality constraints + ; exports <- mapM (mkExport top_lvl prag_fn tyvars_to_gen (map varType dict_vars)) mono_bind_infos ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports] ; traceTc (text "binding:" <+> ppr (poly_ids `zip` map idType poly_ids)) ; let abs_bind = L loc $ AbsBinds tyvars_to_gen - dict_ids exports + dict_vars exports (dict_binds `unionBags` binds') ; return ([unitBag abs_bind], poly_ids) -- poly_ids are guaranteed zonked by mkExport @@ -378,17 +379,18 @@ mkExport top_lvl prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id) = do { warn_missing_sigs <- doptM Opt_WarnMissingSigs ; let warn = isTopLevel top_lvl && warn_missing_sigs ; (tvs, poly_id) <- mk_poly_id warn mb_sig + -- poly_id has a zonked type - ; poly_id' <- zonkId poly_id - ; prags <- tcPrags poly_id' (prag_fn poly_name) + ; prags <- tcPrags poly_id (prag_fn poly_name) -- tcPrags requires a zonked poly_id - ; return (tvs, poly_id', mono_id, prags) } + ; return (tvs, poly_id, mono_id, prags) } where poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id)) - mk_poly_id warn Nothing = do { missingSigWarn warn poly_name poly_ty - ; return (inferred_tvs, mkLocalId poly_name poly_ty) } + mk_poly_id warn Nothing = do { poly_ty' <- zonkTcType poly_ty + ; missingSigWarn warn poly_name poly_ty' + ; return (inferred_tvs, mkLocalId poly_name poly_ty') } mk_poly_id warn (Just sig) = do { tvs <- mapM zonk_tv (sig_tvs sig) ; return (tvs, sig_id sig) } @@ -411,7 +413,7 @@ tcPrags poly_id prags = mapM (wrapLocM tc_prag) prags tc_prag prag = addErrCtxt (pragSigCtxt prag) $ tcPrag poly_id prag -pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag) +pragSigCtxt prag = hang (ptext (sLit "In the pragma")) 2 (ppr prag) tcPrag :: TcId -> Sig Name -> TcM Prag -- Pre-condition: the poly_id is zonked @@ -423,11 +425,10 @@ tcPrag poly_id (InlineSig v inl) = return (InlinePrag inl) tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag tcSpecPrag poly_id hs_ty inl - = do { spec_ty <- tcHsSigType (FunSigCtxt (idName poly_id)) hs_ty - ; (co_fn, lie) <- getLIE (tcSubExp (idType poly_id) spec_ty) - ; extendLIEs lie - ; let const_dicts = map instToId lie - ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty const_dicts inl) } + = do { let name = idName poly_id + ; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty + ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty + ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty inl) } -- Most of the work of specialisation is done by -- the desugarer, guided by the SpecPrag @@ -476,18 +477,18 @@ checkStrictBinds top_lvl rec_group mbind mono_tys infos check_sig other = return () strictBindErr flavour unlifted mbind - = hang (text flavour <+> msg <+> ptext SLIT("aren't allowed:")) + = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) 4 (pprLHsBinds mbind) where - msg | unlifted = ptext SLIT("bindings for unlifted types") - | otherwise = ptext SLIT("bang-pattern bindings") + msg | unlifted = ptext (sLit "bindings for unlifted types") + | otherwise = ptext (sLit "bang-pattern bindings") badStrictSig unlifted sig - = hang (ptext SLIT("Illegal polymorphic signature in") <+> msg) + = hang (ptext (sLit "Illegal polymorphic signature in") <+> msg) 4 (ppr sig) where - msg | unlifted = ptext SLIT("an unlifted binding") - | otherwise = ptext SLIT("a bang-pattern binding") + msg | unlifted = ptext (sLit "an unlifted binding") + | otherwise = ptext (sLit "a bang-pattern binding") \end{code} @@ -546,14 +547,17 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, -- we can (a) use genuine, rigid skolem constants for the type variables -- (b) bring (rigid) scoped type variables into scope setSrcSpan b_loc $ - do { tc_sig <- tcInstSig True name scoped_tvs + do { tc_sig <- tcInstSig True name ; mono_name <- newLocalName name ; let mono_ty = sig_tau tc_sig mono_id = mkLocalId mono_name mono_ty rhs_tvs = [ (name, mkTyVarTy tv) - | (name, tv) <- sig_scoped tc_sig `zip` sig_tvs tc_sig ] + | (name, tv) <- scoped_tvs `zip` sig_tvs tc_sig ] + -- See Note [More instantiated than scoped] + -- Note that the scoped_tvs and the (sig_tvs sig) + -- may have different Names. That's quite ok. - ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $ + ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $ tcMatchesFun mono_name inf matches mono_ty ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, @@ -572,9 +576,9 @@ tcMonoBinds binds sig_fn non_rec -- A monomorphic binding for each term variable that lacks -- a type sig. (Ones with a sig are already in scope.) - ; binds' <- tcExtendIdEnv2 rhs_id_env $ + ; binds' <- tcExtendIdEnv2 rhs_id_env $ do traceTc (text "tcMonoBinds" <+> vcat [ ppr n <+> ppr id <+> ppr (idType id) - | (n,id) <- rhs_id_env]) `thenM_` + | (n,id) <- rhs_id_env]) mapM (wrapLocM tcRhs) tc_binds ; return (listToBag binds', mono_info) } @@ -660,7 +664,11 @@ tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind) ------------------- tcRhs :: TcMonoBind -> TcM (HsBind TcId) -tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches) +-- When we are doing pattern bindings, or multiple function bindings at a time +-- we *don't* bring any scoped type variables into scope +-- Wny not? They are not completely rigid. +-- That's why we have the special case for a single FunBind in tcMonoBinds +tcRhs (TcFunBind (_,_,mono_id) fun' inf matches) = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) inf matches (idType mono_id) ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches', @@ -736,15 +744,15 @@ generalise dflags top_lvl bind_list sig_fn mono_infos lie_req -- Check that signature type variables are OK ; final_qtvs <- checkSigsTyVars qtvs sigs - ; returnM (final_qtvs, sig_lie, binds) } + ; return (final_qtvs, sig_lie, binds) } where bndrs = bndrNames mono_infos sigs = [sig | (_, Just sig, _) <- mono_infos] - tau_tvs = foldr (unionVarSet . exactTyVarsOfType . getMonoType) emptyVarSet mono_infos - -- NB: exactTyVarsOfType; see Note [Silly type synonym] - -- near defn of TcType.exactTyVarsOfType + get_tvs | isTopLevel top_lvl = tyVarsOfType -- See Note [Silly type synonym] in TcType + | otherwise = exactTyVarsOfType + tau_tvs = foldr (unionVarSet . get_tvs . getMonoType) emptyVarSet mono_infos is_mono_sig sig = null (sig_theta sig) - doc = ptext SLIT("type signature(s) for") <+> pprBinders bndrs + doc = ptext (sLit "type signature(s) for") <+> pprBinders bndrs mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_theta = theta, sig_loc = loc }) mono_id @@ -786,13 +794,13 @@ unifyCtxts (sig1 : sigs) -- Argument is always non-empty -- Then unification might succeed with a coercion. But it's much -- much simpler to require that such signatures have identical contexts checkTc (all isIdentityCoercion cois) - (ptext SLIT("Mutually dependent functions have syntactically distinct contexts")) + (ptext (sLit "Mutually dependent functions have syntactically distinct contexts")) } checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar] checkSigsTyVars qtvs sigs = do { gbl_tvs <- tcGetGlobalTyVars - ; sig_tvs_s <- mappM (check_sig gbl_tvs) sigs + ; sig_tvs_s <- mapM (check_sig gbl_tvs) sigs ; let -- Sigh. Make sure that all the tyvars in the type sigs -- appear in the returned ty var list, which is what we are @@ -804,15 +812,15 @@ checkSigsTyVars qtvs sigs -- Here, 'a' won't appear in qtvs, so we have to add it sig_tvs = foldl extendVarSetList emptyVarSet sig_tvs_s all_tvs = varSetElems (extendVarSetList sig_tvs qtvs) - ; returnM all_tvs } + ; return all_tvs } where check_sig gbl_tvs (TcSigInfo {sig_id = id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau}) - = addErrCtxt (ptext SLIT("In the type signature for") <+> quotes (ppr id)) $ + = addErrCtxt (ptext (sLit "In the type signature for") <+> quotes (ppr id)) $ addErrCtxtM (sigCtxt id tvs theta tau) $ do { tvs' <- checkDistinctTyVars tvs - ; ifM (any (`elemVarSet` gbl_tvs) tvs') - (bleatEscapedTvs gbl_tvs tvs tvs') + ; when (any (`elemVarSet` gbl_tvs) tvs') + (bleatEscapedTvs gbl_tvs tvs tvs') ; return tvs' } checkDistinctTyVars :: [TcTyVar] -> TcM [TcTyVar] @@ -843,8 +851,8 @@ checkDistinctTyVars sig_tvs = do { env0 <- tcInitTidyEnv ; let (env1, tidy_tv1) = tidyOpenTyVar env0 sig_tv1 (env2, tidy_tv2) = tidyOpenTyVar env1 sig_tv2 - msg = ptext SLIT("Quantified type variable") <+> quotes (ppr tidy_tv1) - <+> ptext SLIT("is unified with another quantified type variable") + msg = ptext (sLit "Quantified type variable") <+> quotes (ppr tidy_tv1) + <+> ptext (sLit "is unified with another quantified type variable") <+> quotes (ppr tidy_tv2) ; failWithTcM (env2, msg) } where @@ -968,6 +976,44 @@ The @TcSigInfo@ contains @TcTypes@ because they are unified with the variable's type, and after that checked to see whether they've been instantiated. +Note [Scoped tyvars] +~~~~~~~~~~~~~~~~~~~~ +The -XScopedTypeVariables flag brings lexically-scoped type variables +into scope for any explicitly forall-quantified type variables: + f :: forall a. a -> a + f x = e +Then 'a' is in scope inside 'e'. + +However, we do *not* support this + - For pattern bindings e.g + f :: forall a. a->a + (f,g) = e + + - For multiple function bindings, unless Opt_RelaxedPolyRec is on + f :: forall a. a -> a + f = g + g :: forall b. b -> b + g = ...f... + Reason: we use mutable variables for 'a' and 'b', since they may + unify to each other, and that means the scoped type variable would + not stand for a completely rigid variable. + + Currently, we simply make Opt_ScopedTypeVariables imply Opt_RelaxedPolyRec + + +Note [More instantiated than scoped] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There may be more instantiated type variables than lexically-scoped +ones. For example: + type T a = forall b. b -> (a,b) + f :: forall c. T c +Here, the signature for f will have one scoped type variable, c, +but two instantiated type variables, c' and b'. + +We assume that the scoped ones are at the *front* of sig_tvs, +and remember the names from the original HsForAllTy in the TcSigFun. + + \begin{code} type TcSigFun = Name -> Maybe [Name] -- Maps a let-binder to the list of -- type variables brought into scope @@ -984,7 +1030,7 @@ mkTcSigFun sigs = lookupNameEnv env | L span (TypeSig (L _ name) lhs_ty) <- sigs] -- The scoped names are the ones explicitly mentioned -- in the HsForAll. (There may be more in sigma_ty, because - -- of nested type synonyms. See Note [Scoped] with TcSigInfo.) + -- of nested type synonyms. See Note [More instantiated than scoped].) -- See Note [Only scoped tyvars are in the TyVarEnv] --------------- @@ -992,10 +1038,6 @@ data TcSigInfo = TcSigInfo { sig_id :: TcId, -- *Polymorphic* binder for this value... - sig_scoped :: [Name], -- Names for any scoped type variables - -- Invariant: correspond 1-1 with an initial - -- segment of sig_tvs (see Note [Scoped]) - sig_tvs :: [TcTyVar], -- Instantiated type variables -- See Note [Instantiate sig] @@ -1017,17 +1059,6 @@ data TcSigInfo -- only the lexically scoped ones into the environment. --- Note [Scoped] --- There may be more instantiated type variables than scoped --- ones. For example: --- type T a = forall b. b -> (a,b) --- f :: forall c. T c --- Here, the signature for f will have one scoped type variable, c, --- but two instantiated type variables, c' and b'. --- --- We assume that the scoped ones are at the *front* of sig_tvs, --- and remember the names from the original HsForAllTy in sig_scoped - -- Note [Instantiate sig] -- It's vital to instantiate a type signature with fresh variables. -- For example: @@ -1041,7 +1072,7 @@ data TcSigInfo instance Outputable TcSigInfo where ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau}) - = ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau + = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> ppr theta <+> ptext (sLit "=>") <+> ppr tau \end{code} \begin{code} @@ -1058,10 +1089,12 @@ tcInstSig_maybe :: TcSigFun -> Name -> TcM (Maybe TcSigInfo) tcInstSig_maybe sig_fn name = case sig_fn name of Nothing -> return Nothing - Just tvs -> do { tc_sig <- tcInstSig False name tvs - ; return (Just tc_sig) } + Just scoped_tvs -> do { tc_sig <- tcInstSig False name + ; return (Just tc_sig) } + -- NB: the scoped_tvs may be non-empty, but we can + -- just ignore them. See Note [Scoped tyvars]. -tcInstSig :: Bool -> Name -> [Name] -> TcM TcSigInfo +tcInstSig :: Bool -> Name -> TcM TcSigInfo -- Instantiate the signature, with either skolems or meta-type variables -- depending on the use_skols boolean. This variable is set True -- when we are typechecking a single function binding; and False for @@ -1080,7 +1113,7 @@ tcInstSig :: Bool -> Name -> [Name] -> TcM TcSigInfo -- -- We must not use the same 'a' from the defn of T at both places!! -tcInstSig use_skols name scoped_names +tcInstSig use_skols name = do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into -- scope when starting the binding group ; let skol_info = SigSkol (FunSigCtxt name) @@ -1089,15 +1122,7 @@ tcInstSig use_skols name scoped_names ; loc <- getInstLoc (SigOrigin skol_info) ; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau, - sig_scoped = final_scoped_names, sig_loc = loc }) } - -- Note that the scoped_names and the sig_tvs will have - -- different Names. That's quite ok; when we bring the - -- scoped_names into scope, we just bind them to the sig_tvs - where - -- We also only have scoped type variables when we are instantiating - -- with true skolems - final_scoped_names | use_skols = scoped_names - | otherwise = [] + sig_loc = loc }) } ------------------- isMonoGroup :: DynFlags -> [LHsBind Name] -> Bool @@ -1140,14 +1165,14 @@ isRestrictedGroup dflags binds sig_fn -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name patMonoBindsCtxt pat grhss - = hang (ptext SLIT("In a pattern binding:")) 4 (pprPatBind pat grhss) + = hang (ptext (sLit "In a pattern binding:")) 4 (pprPatBind pat grhss) ----------------------------------------------- sigContextsCtxt sig1 sig2 - = vcat [ptext SLIT("When matching the contexts of the signatures for"), + = vcat [ptext (sLit "When matching the contexts of the signatures for"), nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1), ppr id2 <+> dcolon <+> ppr (idType id2)]), - ptext SLIT("The signature contexts in a mutually recursive group should all be identical")] + ptext (sLit "The signature contexts in a mutually recursive group should all be identical")] where id1 = sig_id sig1 id2 = sig_id sig2 @@ -1155,17 +1180,17 @@ sigContextsCtxt sig1 sig2 ----------------------------------------------- unboxedTupleErr name ty - = hang (ptext SLIT("Illegal binding of unboxed tuple")) + = hang (ptext (sLit "Illegal binding of unboxed tuple")) 4 (ppr name <+> dcolon <+> ppr ty) ----------------------------------------------- restrictedBindCtxtErr binder_names - = hang (ptext SLIT("Illegal overloaded type signature(s)")) - 4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names, - ptext SLIT("that falls under the monomorphism restriction")]) + = hang (ptext (sLit "Illegal overloaded type signature(s)")) + 4 (vcat [ptext (sLit "in a binding group for") <+> pprBinders binder_names, + ptext (sLit "that falls under the monomorphism restriction")]) genCtxt binder_names - = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names + = ptext (sLit "When generalising the type(s) for") <+> pprBinders binder_names missingSigWarn False name ty = return () missingSigWarn True name ty @@ -1173,6 +1198,6 @@ missingSigWarn True name ty ; let (env1, tidy_ty) = tidyOpenType env0 ty ; addWarnTcM (env1, mk_msg tidy_ty) } where - mk_msg ty = vcat [ptext SLIT("Definition but no type signature for") <+> quotes (ppr name), - sep [ptext SLIT("Inferred type:") <+> ppr name <+> dcolon <+> ppr ty]] + mk_msg ty = vcat [ptext (sLit "Definition but no type signature for") <+> quotes (ppr name), + sep [ptext (sLit "Inferred type:") <+> pprHsVar name <+> dcolon <+> ppr ty]] \end{code}