[project @ 1998-01-27 14:53:40 by simonpj]

Fix misleading type checker error msgs; fix broken floatBind in Simplify.lhs

ghc/compiler/simplCore/Simplify.lhs

@@ -947,7 +947,8 @@ simplNonRec env binder@(id,occ_info) rhs body_c body_ty
     -- Try let-from-let
     simpl_bind env (Let bind rhs) | let_floating_ok
       = tick LetFloatFromLet                    `thenSmpl_`
-	simplBind env (fix_up_demandedness will_be_demanded bind)
+	simplBind env (if will_be_demanded then bind 
+					   else un_demandify_bind bind)
 		      (\env -> simpl_bind env rhs) body_ty
 
     -- Try case-from-let; this deals with a strict let of error too
@@ -1276,7 +1277,8 @@ floatBind env top_level bind
     returnSmpl binds'
 
   where
-    (binds', _, n_extras) = fltBind bind	
+    binds'   = fltBind bind
+    n_extras = sum (map no_of_binds binds') - no_of_binds bind 
 
     float_lets		      = switchIsSet env SimplFloatLetsExposingWHNF
     always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
@@ -1284,27 +1286,22 @@ floatBind env top_level bind
 	-- fltBind guarantees not to return leaky floats
 	-- and all the binders of the floats have had their demand-info zapped
     fltBind (NonRec bndr rhs)
-      = (binds ++ [NonRec (un_demandify bndr) rhs'], 
-	 leakFree bndr rhs', 
-	 length binds)
+      = binds ++ [NonRec bndr rhs'] 
       where
         (binds, rhs') = fltRhs rhs
     
     fltBind (Rec pairs)
-      = ([Rec (extras
-      	       ++
-	       binders `zip` rhss')],
-         and (zipWith leakFree binders rhss'),
-	 length extras
-        )
-    
+      = [Rec pairs']
       where
-        (binders, rhss)  = unzip pairs
-        (binds_s, rhss') = mapAndUnzip fltRhs rhss
-	extras		 = concat (map get_pairs (concat binds_s))
-
-        get_pairs (NonRec bndr rhs) = [(bndr,rhs)]
-        get_pairs (Rec pairs)       = pairs
+        pairs' = concat [ let
+				(binds, rhs') = fltRhs rhs
+		          in
+			  foldr get_pairs [(bndr, rhs')] binds
+			| (bndr, rhs) <- pairs
+			]
+
+        get_pairs (NonRec bndr rhs) rest = (bndr,rhs) :  rest
+        get_pairs (Rec pairs)       rest = pairs      ++ rest
     
 	-- fltRhs has same invariant as fltBind
     fltRhs rhs
@@ -1322,12 +1319,19 @@ floatBind env top_level bind
             -- fltExpr guarantees not to return leaky floats
       = (binds' ++ body_binds, body')
       where
-        (body_binds, body')	     = fltExpr body
-        (binds', binds_wont_leak, _) = fltBind bind
+        binds_wont_leak     = all leakFreeBind binds'
+        (body_binds, body') = fltExpr body
+        binds'		    = fltBind (un_demandify_bind bind)
     
     fltExpr expr = ([], expr)
 
 -- Crude but effective
+no_of_binds (NonRec _ _) = 1
+no_of_binds (Rec pairs)  = length pairs
+
+leakFreeBind (NonRec bndr rhs) = leakFree bndr rhs
+leakFreeBind (Rec pairs)       = and [leakFree bndr rhs | (bndr, rhs) <- pairs]
+
 leakFree (id,_) rhs = case getIdArity id of
 			ArityAtLeast n | n > 0 -> True
 			ArityExactly n | n > 0 -> True
@@ -1358,16 +1362,14 @@ simplArg env (VarArg id)  = lookupId env id
 
 
 \begin{code}
--- fix_up_demandedness switches off the willBeDemanded Info field
+-- un_demandify_bind switches off the willBeDemanded Info field
 -- for bindings floated out of a non-demanded let
-fix_up_demandedness True {- Will be demanded -} bind
-   = bind	-- Simple; no change to demand info needed
-fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
-   = NonRec (un_demandify binder) rhs
-fix_up_demandedness False {- May not be demanded -} (Rec pairs)
-   = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
-
-un_demandify (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
+un_demandify_bind (NonRec binder rhs)
+   = NonRec (un_demandify_bndr binder) rhs
+un_demandify_bind (Rec pairs)
+   = Rec [(un_demandify_bndr binder, rhs) | (binder,rhs) <- pairs]
+
+un_demandify_bndr (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
 
 is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
 is_cheap_prim_app other	      = False

ghc/compiler/typecheck/TcExpr.lhs

@@ -99,7 +99,7 @@ tcExpr :: RenamedHsExpr			-- Expession to type check
 \begin{code}
 tcExpr (HsVar name) res_ty
   = tcId name			`thenNF_Tc` \ (expr', lie, id_ty) ->
-    unifyTauTy id_ty res_ty	`thenTc_`
+    unifyTauTy res_ty id_ty 	`thenTc_`
 
     -- Check that the result type doesn't have any nested for-alls.
     -- For example, a "build" on its own is no good; it must be
@@ -306,16 +306,24 @@ tcExpr (HsLet binds expr) res_ty
 	      returnTc (expr', lie)
     combiner is_rec bind expr = HsLet (MonoBind bind [] is_rec) expr
 
-tcExpr in_expr@(HsCase expr matches src_loc) res_ty
-  = tcAddSrcLoc src_loc	$
-    newTyVarTy mkTypeKind 	`thenNF_Tc` \ expr_ty ->
-    tcExpr expr expr_ty		`thenTc`    \ (expr',lie1) ->
+tcExpr in_expr@(HsCase scrut matches src_loc) res_ty
+  = tcAddSrcLoc src_loc			$
+    tcAddErrCtxt (caseCtxt in_expr)	$
+
+	-- Typecheck the case alternatives first.
+	-- The case patterns tend to give good type info to use
+	-- when typechecking the scrutinee.  For example
+	--	case (map f) of
+	--	  (x:xs) -> ...
+	-- will report that map is applied to too few arguments
 
-    tcAddErrCtxt (caseCtxt in_expr) $
-    tcMatchesCase (mkFunTy expr_ty res_ty) matches	
-				`thenTc`    \ (matches',lie2) ->
+    tcMatchesCase res_ty matches	`thenTc`    \ (scrut_ty, matches', lie2) ->
 
-    returnTc (HsCase expr' matches' src_loc, plusLIE lie1 lie2)
+    tcAddErrCtxt (caseScrutCtxt scrut)	(
+      tcExpr scrut scrut_ty
+    )					`thenTc`    \ (scrut',lie1) ->
+
+    returnTc (HsCase scrut' matches' src_loc, plusLIE lie1 lie2)
 
 tcExpr (HsIf pred b1 b2 src_loc) res_ty
   = tcAddSrcLoc src_loc	$
@@ -357,7 +365,7 @@ tcExpr (RecordCon con_name _ rbinds) res_ty
     in
 	-- Con is syntactically constrained to be a data constructor
     ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
-    unifyTauTy record_ty res_ty         `thenTc_`
+    unifyTauTy res_ty record_ty          `thenTc_`
 
 	-- Check that the record bindings match the constructor
     let
@@ -432,7 +440,7 @@ tcExpr (RecordUpd record_expr rbinds) res_ty
     let
 	result_record_ty = mkTyConApp tycon result_inst_tys
     in
-    unifyTauTy result_record_ty res_ty          `thenTc_`
+    unifyTauTy res_ty result_record_ty          `thenTc_`
     tcRecordBinds result_record_ty rbinds	`thenTc` \ (rbinds', rbinds_lie) ->
 
 	-- STEP 4
@@ -1034,6 +1042,9 @@ arithSeqCtxt expr
 caseCtxt expr
   = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
 
+caseScrutCtxt expr
+  = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
+
 exprSigCtxt expr
   = hang (ptext SLIT("In an expression with a type signature:"))
 	 4 (ppr expr)

ghc/compiler/typecheck/TcMatches.lhs

@@ -21,7 +21,7 @@ import TcMonad
 import Inst		( Inst, LIE, plusLIE )
 import TcEnv		( TcIdOcc(..), newMonoIds )
 import TcPat		( tcPat )
-import TcType		( TcType, TcMaybe, zonkTcType )
+import TcType		( TcType, TcMaybe, zonkTcType, newTyVarTy )
 import TcSimplify	( bindInstsOfLocalFuns )
 import Unify		( unifyTauTy, unifyTauTyList, unifyFunTy )
 import Name		( Name {- instance Outputable -} )
@@ -78,8 +78,16 @@ tcMatchesFun fun_name expected_ty matches@(first_match:_)
 parser guarantees that each equation has exactly one argument.
 
 \begin{code}
-tcMatchesCase :: TcType s -> [RenamedMatch] -> TcM s ([TcMatch s], LIE s)
-tcMatchesCase expected_ty matches = tcMatchesExpected expected_ty MCase matches
+tcMatchesCase :: TcType s 		-- Type of whole case expressions
+	      -> [RenamedMatch]		-- The case alternatives
+	      -> TcM s (TcType s,	-- Inferred type of the scrutinee
+			[TcMatch s], 	-- Translated alternatives
+			LIE s)
+
+tcMatchesCase expr_ty matches
+  = newTyVarTy mkTypeKind 					`thenNF_Tc` \ scrut_ty ->
+    tcMatchesExpected (mkFunTy scrut_ty expr_ty) MCase matches	`thenTc` \ (matches', lie) ->
+    returnTc (scrut_ty, matches', lie)
 \end{code}
 
 

ghc/compiler/typecheck/Unify.lhs

@@ -311,7 +311,7 @@ unifyFunTy ty
 unify_fun_ty_help ty	-- Special cases failed, so revert to ordinary unification
   = newTyVarTy mkTypeKind		`thenNF_Tc` \ arg ->
     newTyVarTy mkTypeKind		`thenNF_Tc` \ res ->
-    unifyTauTy (mkFunTy arg res) ty	`thenTc_`
+    unifyTauTy ty (mkFunTy arg res)	`thenTc_`
     returnTc (arg,res)
 \end{code}
 
@@ -332,7 +332,7 @@ unifyListTy ty
 
 unify_list_ty_help ty	-- Revert to ordinary unification
   = newTyVarTy mkBoxedTypeKind		`thenNF_Tc` \ elt_ty ->
-    unifyTauTy (mkListTy elt_ty) ty	`thenTc_`
+    unifyTauTy ty (mkListTy elt_ty)	`thenTc_`
     returnTc elt_ty
 \end{code}
 
@@ -353,7 +353,7 @@ unifyTupleTy arity ty
 
 unify_tuple_ty_help arity ty
   = mapNF_Tc (\ _ -> newTyVarTy mkBoxedTypeKind) [1..arity]	`thenNF_Tc` \ arg_tys ->
-    unifyTauTy (mkTupleTy arity arg_tys) ty			`thenTc_`
+    unifyTauTy ty (mkTupleTy arity arg_tys)			`thenTc_`
     returnTc arg_tys
 \end{code}