From: simonpj <unknown>
Date: Fri, 30 Nov 2001 09:32:28 +0000 (+0000)
Subject: [project @ 2001-11-30 09:32:27 by simonpj]
X-Git-Tag: Approximately_9120_patches~486
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=1d874e7c18d8b1bd46cbb27c3e146b092a64fc63;p=ghc-hetmet.git

[project @ 2001-11-30 09:32:27 by simonpj]
Wibbles to rank-N
---

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 2f3a888..76fc669 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -814,5 +814,7 @@ genCtxt binder_names
   = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names
 
 -- Used in error messages
-pprBinders bndrs = pprWithCommas ppr bndrs
+-- Use quotes for a single one; they look a bit "busy" for several
+pprBinders [bndr] = quotes (ppr bndr)
+pprBinders bndrs  = pprWithCommas ppr bndrs
 \end{code}
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index b66730a..6039559 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -593,16 +593,18 @@ tcApp fun args res_ty
 	split_fun_ty fun_ty (length args)
     )						`thenTc` \ (expected_arg_tys, actual_result_ty) ->
 
-	-- Unify with expected result before type-checking the args
-	-- so that the info from res_ty percolates to expected_arg_tys
-	-- This is when we might detect a too-few args situation
-    tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty)
-		  (tcSub res_ty actual_result_ty)	`thenTc` \ (co_fn, lie_res) ->
-
 	-- Now typecheck the args
     mapAndUnzipTc (tcArg fun)
 	  (zip3 args expected_arg_tys [1..])	`thenTc` \ (args', lie_args_s) ->
 
+	-- Unify with expected result after type-checking the args
+	-- so that the info from args percolates to actual_result_ty.
+	-- This is when we might detect a too-few args situation.
+	-- (One can think of cases when the opposite order would give
+	-- a better error message.)
+    tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty)
+		  (tcSub res_ty actual_result_ty)	`thenTc` \ (co_fn, lie_res) ->
+
     returnTc (co_fn <$> foldl HsApp fun' args', 
 	      lie_res `plusLIE` lie_fun `plusLIE` plusLIEs lie_args_s)
 
@@ -674,7 +676,7 @@ Typecheck expression which in most cases will be an Id.
 tcExpr_id :: RenamedHsExpr -> TcM (TcExpr, LIE, TcType)
 tcExpr_id (HsVar name) = tcId name
 tcExpr_id expr         = newTyVarTy openTypeKind	`thenNF_Tc` \ id_ty ->
-			 tcMonoExpr expr id_ty	`thenTc`    \ (expr', lie_id) ->
+			 tcMonoExpr expr id_ty		`thenTc`    \ (expr', lie_id) ->
 		         returnTc (expr', lie_id, id_ty) 
 \end{code}
 
diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs
index 4cdab86..e9d36c4 100644
--- a/ghc/compiler/typecheck/TcUnify.lhs
+++ b/ghc/compiler/typecheck/TcUnify.lhs
@@ -179,8 +179,13 @@ tc_sub _ (FunTy exp_arg exp_res) _ (FunTy act_arg act_res)
 
 -----------------------------------
 -- Type variable meets function: imitate
-
--- MARK: can we short-cut to an error case?
+--
+-- NB 1: we can't just unify the type variable with the type
+--	 because the type might not be a tau-type, and we aren't
+--	 allowed to instantiate an ordinary type variable with
+--	 a sigma-type
+--
+-- NB 2: can we short-cut to an error case?
 --	 when the arg/res is not a tau-type?
 -- NO!  e.g.   f :: ((forall a. a->a) -> Int) -> Int
 --	then   x = (f,f)
@@ -190,14 +195,14 @@ tc_sub exp_sty exp_ty@(FunTy exp_arg exp_res) _ (TyVarTy tv)
   = getTcTyVar tv	`thenNF_Tc` \ maybe_ty ->
     case maybe_ty of
 	Just ty -> tc_sub exp_sty exp_ty ty ty
-	Nothing -> imitateFun tv	`thenNF_Tc` \ (act_arg, act_res) ->
+	Nothing -> imitateFun tv exp_sty	`thenNF_Tc` \ (act_arg, act_res) ->
 		   tcSub_fun exp_arg exp_res act_arg act_res
 
 tc_sub _ (TyVarTy tv) act_sty act_ty@(FunTy act_arg act_res)
   = getTcTyVar tv	`thenNF_Tc` \ maybe_ty ->
     case maybe_ty of
 	Just ty -> tc_sub ty ty act_sty act_ty
-	Nothing -> imitateFun tv	`thenNF_Tc` \ (exp_arg, exp_res) ->
+	Nothing -> imitateFun tv act_sty	`thenNF_Tc` \ (exp_arg, exp_res) ->
 		   tcSub_fun exp_arg exp_res act_arg act_res
 
 -----------------------------------
@@ -238,12 +243,19 @@ tcSub_fun exp_arg exp_res act_arg act_res
     in
     returnTc (coercion, lie1 `plusLIE` lie2)
 
-imitateFun :: TcTyVar -> NF_TcM (TcType, TcType)
-imitateFun tv
+imitateFun :: TcTyVar -> TcType -> NF_TcM (TcType, TcType)
+imitateFun tv ty
   = ASSERT( not (isHoleTyVar tv) )
+	-- NB: tv is an *ordinary* tyvar and so are the new ones
+
+   	-- Check that tv isn't a type-signature type variable
+	-- (This would be found later in checkSigTyVars, but
+	--  we get a better error message if we do it here.)
+    checkTcM (not (isSkolemTyVar tv))
+	     (failWithTcM (unifyWithSigErr tv ty))	`thenTc_`
+
     newTyVarTy openTypeKind		`thenNF_Tc` \ arg ->
     newTyVarTy openTypeKind		`thenNF_Tc` \ res ->
-	-- NB: tv is an *ordinary* tyvar and so are the new ones
     putTcTyVar tv (mkFunTy arg res)	`thenNF_Tc_`
     returnNF_Tc (arg,res)
 \end{code}