X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=342529ca9adf77f79d96b8867260fe9f9f71c0d6;hb=bb91427f27c940e4dd0fc6c7360e7ef61264b240;hp=6a64ece447fa00b38753e2bceab41ac424273dde;hpb=e1e1d0204ff754def1b3675f539372fd4691d78d;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 6a64ece..342529c 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -13,7 +13,7 @@ import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
 import {-# SOURCE #-} TcExpr  ( tcExpr )
 
 import HsSyn		( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..),
-			  collectMonoBinders, andMonoBindList, andMonoBinds
+			  Match(..), collectMonoBinders, andMonoBindList, andMonoBinds
 			)
 import RnHsSyn		( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
 import TcHsSyn		( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
@@ -21,6 +21,7 @@ import TcHsSyn		( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
 import TcMonad
 import Inst		( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
 			  newDicts, tyVarsOfInst, instToId,
+			  getAllFunDepsOfLIE, getIPsOfLIE, zonkFunDeps
 			)
 import TcEnv		( tcExtendLocalValEnv,
 			  newSpecPragmaId, newLocalId,
@@ -28,7 +29,8 @@ import TcEnv		( tcExtendLocalValEnv,
 			  tcGetGlobalTyVars, tcExtendGlobalTyVars
 			)
 import TcSimplify	( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
-import TcMonoType	( tcHsType, checkSigTyVars,
+import TcImprove	( tcImprove )
+import TcMonoType	( tcHsSigType, checkSigTyVars,
 			  TcSigInfo(..), tcTySig, maybeSig, sigCtxt
 			)
 import TcPat		( tcPat )
@@ -42,16 +44,17 @@ import TcUnify		( unifyTauTy, unifyTauTyLists )
 
 import PrelInfo		( main_NAME, ioTyCon_NAME )
 
-import Id		( Id, mkVanillaId, setInlinePragma )
+import Id		( Id, mkVanillaId, setInlinePragma, idFreeTyVars )
 import Var		( idType, idName )
-import IdInfo		( IdInfo, vanillaIdInfo, setInlinePragInfo, InlinePragInfo(..) )
+import IdInfo		( setInlinePragInfo, InlinePragInfo(..) )
 import Name		( Name, getName, getOccName, getSrcLoc )
 import NameSet
 import Type		( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
 			  splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, 
-			  mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType, 
+			  mkPredTy, splitRhoTy, mkForAllTy, isUnLiftedType, 
 			  isUnboxedType, unboxedTypeKind, boxedTypeKind
 			)
+import FunDeps		( tyVarFunDep, oclose )
 import Var		( TyVar, tyVarKind )
 import VarSet
 import Bag
@@ -250,6 +253,17 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
 	-- (must do this before getTyVarsToGen)
     checkSigMatch top_lvl binder_names mono_ids tc_ty_sigs	`thenTc` \ maybe_sig_theta ->	
 
+	-- IMPROVE the LIE
+	-- Force any unifications dictated by functional dependencies.
+	-- Because unification may happen, it's important that this step
+	-- come before:
+	--   - computing vars over which to quantify
+	--   - zonking the generalized type vars
+    let lie_avail = case maybe_sig_theta of
+		      Nothing	   -> emptyLIE
+		      Just (_, la) -> la in
+    tcImprove (lie_avail `plusLIE` lie_req)			`thenTc_`
+
 	-- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
 	-- The tyvars_not_to_gen are free in the environment, and hence
 	-- candidates for generalisation, but sometimes the monomorphism
@@ -279,8 +293,9 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
 
 	-- SIMPLIFY THE LIE
     tcExtendGlobalTyVars tyvars_not_to_gen (
-	if null real_tyvars_to_gen_list then
-		-- No polymorphism, so no need to simplify context
+	let ips = getIPsOfLIE lie_req in
+	if null real_tyvars_to_gen_list && (null ips || not is_unrestricted) then
+		-- No polymorphism, and no IPs, so no need to simplify context
 	    returnTc (lie_req, EmptyMonoBinds, [])
 	else
 	case maybe_sig_theta of
@@ -289,7 +304,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
 		-- NB: no signatures => no polymorphic recursion, so no
 		-- need to use lie_avail (which will be empty anyway)
 	    tcSimplify (text "tcBinds1" <+> ppr binder_names)
-		       top_lvl real_tyvars_to_gen lie_req	`thenTc` \ (lie_free, dict_binds, lie_bound) ->
+		       real_tyvars_to_gen lie_req	`thenTc` \ (lie_free, dict_binds, lie_bound) ->
 	    returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
 
 	  Just (sig_theta, lie_avail) ->
@@ -397,6 +412,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
 
 	 -- BUILD RESULTS
     returnTc (
+	 -- pprTrace "binding.." (ppr ((dicts_bound, dict_binds), exports, [idType poly_id | (_, poly_id, _) <- exports])) $
 	 AbsBinds real_tyvars_to_gen_list
 		  dicts_bound
 		  exports
@@ -524,22 +540,27 @@ getTyVarsToGen is_unrestricted mono_id_tys lie
   = tcGetGlobalTyVars			`thenNF_Tc` \ free_tyvars ->
     zonkTcTypes mono_id_tys		`thenNF_Tc` \ zonked_mono_id_tys ->
     let
-	tyvars_to_gen = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
+	body_tyvars = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
     in
     if is_unrestricted
     then
-	returnNF_Tc (emptyVarSet, tyvars_to_gen)
+	let fds = getAllFunDepsOfLIE lie in
+	zonkFunDeps fds		`thenNF_Tc` \ fds' ->
+	let tvFundep = tyVarFunDep fds'
+	    extended_tyvars = oclose tvFundep body_tyvars in
+	-- pprTrace "gTVTG" (ppr (lie, body_tyvars, extended_tyvars)) $
+	returnNF_Tc (emptyVarSet, extended_tyvars)
     else
 	-- This recover and discard-errs is to avoid duplicate error
 	-- messages; this, after all, is an "extra" call to tcSimplify
-	recoverNF_Tc (returnNF_Tc (emptyVarSet, tyvars_to_gen))		$
+	recoverNF_Tc (returnNF_Tc (emptyVarSet, body_tyvars))		$
 	discardErrsTc							$
 
-	tcSimplify (text "getTVG") NotTopLevel tyvars_to_gen lie    `thenTc` \ (_, _, constrained_dicts) ->
+	tcSimplify (text "getTVG") body_tyvars lie    `thenTc` \ (_, _, constrained_dicts) ->
 	let
 	  -- ASSERT: dicts_sig is already zonked!
 	    constrained_tyvars    = foldrBag (unionVarSet . tyVarsOfInst) emptyVarSet constrained_dicts
-	    reduced_tyvars_to_gen = tyvars_to_gen `minusVarSet` constrained_tyvars
+	    reduced_tyvars_to_gen = body_tyvars `minusVarSet` constrained_tyvars
         in
         returnTc (constrained_tyvars, reduced_tyvars_to_gen)
 \end{code}
@@ -552,13 +573,16 @@ isUnRestrictedGroup :: [Name]		-- Signatures given for these
 
 is_elem v vs = isIn "isUnResMono" v vs
 
-isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs
 isUnRestrictedGroup sigs (PatMonoBind other        _ _) = False
 isUnRestrictedGroup sigs (VarMonoBind v _)	        = v `is_elem` sigs
-isUnRestrictedGroup sigs (FunMonoBind _ _ _ _)		= True
+isUnRestrictedGroup sigs (FunMonoBind v _ matches _)	= any isUnRestrictedMatch matches || 
+							  v `is_elem` sigs
 isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2)		= isUnRestrictedGroup sigs mb1 &&
 							  isUnRestrictedGroup sigs mb2
 isUnRestrictedGroup sigs EmptyMonoBinds			= True
+
+isUnRestrictedMatch (Match _ [] Nothing _) = False	-- No args, no signature
+isUnRestrictedMatch other		   = True	-- Some args or a signature
 \end{code}
 
 
@@ -748,10 +772,10 @@ checkSigMatch top_lvl binder_names mono_ids sigs
 		      
    	-- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
 	-- Doesn't affect substitution
-    check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc)
+    check_one_sig (TySigInfo _ id sig_tyvars sig_theta sig_tau _ _ src_loc)
       = tcAddSrcLoc src_loc					$
-	tcAddErrCtxtM (sigCtxt (sig_msg id) (idType id))	$
-	checkSigTyVars sig_tyvars
+	tcAddErrCtxtM (sigCtxt (sig_msg id) sig_tyvars sig_theta sig_tau)	$
+	checkSigTyVars sig_tyvars (idFreeTyVars id)
 
 
 	-- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
@@ -776,10 +800,9 @@ checkSigMatch top_lvl binder_names mono_ids sigs
 	= tcAddSrcLoc src_loc	$
 	  checkTc (null theta) (mainContextsErr id)
 
-    mk_dict_tys theta = [mkDictTy c ts | (c,ts) <- theta]
+    mk_dict_tys theta = map mkPredTy theta
 
-    sig_msg id tidy_ty = sep [ptext SLIT("When checking the type signature"),
-			      nest 4 (ppr id <+> dcolon <+> ppr tidy_ty)]
+    sig_msg id = ptext SLIT("When checking the type signature for") <+> quotes (ppr id)
 
 	-- Search for Main.main in the binder_names, return corresponding mono_id
     find_main NotTopLevel binder_names mono_ids = Nothing
@@ -839,7 +862,7 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
     tcAddErrCtxt (valSpecSigCtxt name poly_ty)	$
 
 	-- Get and instantiate its alleged specialised type
-    tcHsType poly_ty				`thenTc` \ sig_ty ->
+    tcHsSigType poly_ty				`thenTc` \ sig_ty ->
 
 	-- Check that f has a more general type, and build a RHS for
 	-- the spec-pragma-id at the same time