From 8e3bfa9b311ee374bd904604216a01d727e78fa1 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Tue, 27 Jan 1998 14:53:51 +0000
Subject: [PATCH] [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 | 60 ++++++++++++++--------------
ghc/compiler/typecheck/TcExpr.lhs | 33 ++++++++++-----
ghc/compiler/typecheck/TcMatches.lhs | 14 +++++--
ghc/compiler/typecheck/Unify.lhs | 6 +--
4 files changed, 67 insertions(+), 46 deletions(-)
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 97b698fb1b1c..b996b722c733 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/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
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 0ac4f084e4ec..34bb8cce2823 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/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)
diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index 69af3b29d0dc..9185d6054f2a 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/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}
diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs
index c5a29fc3a2aa..439ccdaaf9ff 100644
--- a/ghc/compiler/typecheck/Unify.lhs
+++ b/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}
--
GitLab