X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=671bfeac4c742376fa6d7ad0c3dd4418b926b259;hb=421819753b3eb4940a26e578ef0e4c5cd31761fa;hp=351b6d8a2567987e1c3ecac285fb5438a9f5ad8a;hpb=970d5b88b1554bbdd7e459dae41aab3668ae897a;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 351b6d8..671bfea 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -5,6 +5,13 @@ \section[TcBinds]{TcBinds} \begin{code} +{-# 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/Commentary/CodingStyle#Warnings +-- for details + module TcBinds ( tcLocalBinds, tcTopBinds, tcHsBootSigs, tcMonoBinds, TcPragFun, tcSpecPrag, tcPrags, mkPragFun, @@ -30,6 +37,7 @@ import TcPat import TcMType import TcType import {- Kind parts of -} Type +import Coercion import VarEnv import TysPrim import Id @@ -241,7 +249,7 @@ tc_haskell98 top_lvl sig_fn prag_fn rec_flag binds thing_inside bindLocalInsts :: TopLevelFlag -> TcM ([LHsBinds TcId], [TcId], a) -> TcM ([LHsBinds TcId], a) bindLocalInsts top_lvl thing_inside | isTopLevel top_lvl = do { (binds, ids, thing) <- thing_inside; return (binds, thing) } - -- For the top level don't bother will all this bindInstsOfLocalFuns stuff. + -- For the top level don't bother with all this bindInstsOfLocalFuns stuff. -- All the top level things are rec'd together anyway, so it's fine to -- leave them to the tcSimplifyTop, and quite a bit faster too @@ -511,7 +519,7 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, -- e.g. f = \(x::forall a. a->a) -> -- We want to infer a higher-rank type for f setSrcSpan b_loc $ - do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name matches) + do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches) -- Check for an unboxed tuple type -- f = (# True, False #) @@ -546,7 +554,7 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, | (name, tv) <- sig_scoped tc_sig `zip` sig_tvs tc_sig ] ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $ - tcMatchesFun mono_name matches mono_ty + tcMatchesFun mono_name inf matches mono_ty ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, fun_infix = inf, fun_matches = matches', @@ -653,8 +661,8 @@ tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind) ------------------- tcRhs :: TcMonoBind -> TcM (HsBind TcId) tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches) - = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) matches - (idType mono_id) + = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) inf + matches (idType mono_id) ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches', bind_fvs = placeHolderNames, fun_co_fn = co_fn, fun_tick = Nothing }) } @@ -769,7 +777,17 @@ unifyCtxts (sig1 : sigs) -- Argument is always non-empty unify_ctxt sig@(TcSigInfo { sig_theta = theta }) = setSrcSpan (instLocSpan (sig_loc sig)) $ addErrCtxt (sigContextsCtxt sig1 sig) $ - unifyTheta theta1 theta + do { cois <- unifyTheta theta1 theta + ; -- Check whether all coercions are identity coercions + -- That can happen if we have, say + -- f :: C [a] => ... + -- g :: C (F a) => ... + -- where F is a type function and (F a ~ [a]) + -- 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")) + } checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar] checkSigsTyVars qtvs sigs