[project @ 2000-05-13 00:20:57 by lewie]

A clean-up pass on fundeps and implicit params.  Haven't yet incorporated
changes from Hugs/GHC meeting yet, tho.
  - Fixed up several places in Type.lhs where IPNotes were probably being
    incorrectly handled.  Strongly suggests a better solution should be
    implemented for marking implicit params than piggybacking on NoteTys.
  - tcSimplifyAndCheck was handling implicit params incorrectly
    (holding on to them when it should have been booting them out to frees).
  - Improved improvement WRT type signatures (the signature is now taken
    into account when improving).
  - Added improvement when matching against local polymorphic types.

8 files changed, 74 insertions, 52 deletions

diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index fe95b3c6f3..7f47891852 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -298,6 +298,9 @@ ppr_con_details con (RecCon fields)
 			 dcolon <+>
 			 ppr_bang ty
 
+instance Outputable name => Outputable (BangType name) where
+    ppr = ppr_bang
+
 ppr_bang (Banged   ty) = ptext SLIT("!") <> pprParendHsType ty
 ppr_bang (Unbanged ty) = pprParendHsType ty
 ppr_bang (Unpacked ty) = ptext SLIT("! !") <> pprParendHsType ty
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 1a360513e8..b252acae08 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -259,7 +259,10 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
 	-- come before:
 	--   - computing vars over which to quantify
 	--   - zonking the generalized type vars
-    tcImprove lie_req `thenTc_`
+    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
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 100a838a7b..81b468f662 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -38,6 +38,7 @@ import TcMatches	( tcMatchesCase, tcMatchLambda, tcStmts )
 import TcMonoType	( tcHsSigType, checkSigTyVars, sigCtxt )
 import TcPat		( badFieldCon )
 import TcSimplify	( tcSimplify, tcSimplifyAndCheck, partitionPredsOfLIE )
+import TcImprove	( tcImprove )
 import TcType		( TcType, TcTauType,
 			  tcInstTyVars,
 			  tcInstTcType, tcSplitRhoTy,
@@ -60,7 +61,7 @@ import Type		( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
 			  mkTyConApp, splitSigmaTy, 
 			  splitRhoTy,
 			  isTauTy, tyVarsOfType, tyVarsOfTypes, 
-			  isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
+			  isSigmaTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
 			  boxedTypeKind, mkArrowKind,
 			  tidyOpenType
 			)
@@ -99,12 +100,12 @@ tcExpr :: RenamedHsExpr			-- Expession to type check
 	-> TcType 			-- Expected type (could be a polytpye)
 	-> TcM s (TcExpr, LIE)
 
-tcExpr expr ty | isForAllTy ty = -- Polymorphic case
-				 tcPolyExpr expr ty 	`thenTc` \ (expr', lie, _, _, _) ->
+tcExpr expr ty | isSigmaTy ty = -- Polymorphic case
+				tcPolyExpr expr ty 	`thenTc` \ (expr', lie, _, _, _) ->
 				 returnTc (expr', lie)
 
-	       | otherwise     = -- Monomorphic case
-				 tcMonoExpr expr ty
+	       | otherwise    = -- Monomorphic case
+				tcMonoExpr expr ty
 \end{code}
 
 
@@ -153,6 +154,7 @@ tcPolyExpr arg expected_arg_ty
     checkSigTyVars sig_tyvars free_tyvars	`thenTc` \ zonked_sig_tyvars ->
 
     newDicts SignatureOrigin sig_theta		`thenNF_Tc` \ (sig_dicts, dict_ids) ->
+    tcImprove (sig_dicts `plusLIE` lie_arg)	`thenTc_`
 	-- ToDo: better origin
     tcSimplifyAndCheck 
 	(text "the type signature of an expression")
@@ -701,7 +703,7 @@ tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
  = tcSetErrCtxt (exprSigCtxt in_expr)	$
    tcHsSigType  poly_ty		`thenTc` \ sig_tc_ty ->
 
-   if not (isForAllTy sig_tc_ty) then
+   if not (isSigmaTy sig_tc_ty) then
 	-- Easy case
 	unifyTauTy sig_tc_ty res_ty	`thenTc_`
 	tcMonoExpr expr sig_tc_ty
@@ -731,7 +733,6 @@ tcMonoExpr (HsWith expr binds) res_ty
   = tcMonoExpr expr res_ty		`thenTc` \ (expr', lie) ->
     tcIPBinds binds			`thenTc` \ (binds', types, lie2) ->
     partitionPredsOfLIE isBound lie	`thenTc` \ (ips, lie', dict_binds) ->
-    pprTrace "tcMonoExpr With" (ppr (ips, lie', dict_binds)) $
     let expr'' = if nullMonoBinds dict_binds
 		 then expr'
 		 else HsLet (mkMonoBind (revBinds dict_binds) [] NonRecursive)
diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs
index 77e9e42851..e814e06386 100644
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -41,9 +41,6 @@ import Name		( nameOccName )
 import Type		( splitFunTys
 			, splitTyConApp_maybe
 			, splitForAllTys
-			, splitRhoTy
-			, isForAllTy
-			, mkForAllTys
 			)
 import PprType		( {- instance Outputable Type -} )
 import TysWiredIn	( isFFIArgumentTy, isFFIResultTy, 
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index f1467ba454..08b2211cfb 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -255,8 +255,8 @@ tcSimplify str local_tvs wanted_lie
 
       -- We're infering (not checking) the type, and 
       -- the inst constrains a local type variable
-      | isDict inst  = DontReduceUnlessConstant	-- Dicts
-      | otherwise    = ReduceMe AddToIrreds	-- Lits and Methods
+      | isClassDict inst = DontReduceUnlessConstant	-- Dicts
+      | otherwise	 = ReduceMe AddToIrreds		-- Lits and Methods
 \end{code}
 
 @tcSimplifyAndCheck@ is similar to the above, except that it checks
@@ -292,13 +292,13 @@ tcSimplifyAndCheck str local_tvs given_lie wanted_lie
   where
     givens  = lieToList given_lie
     -- see comment on wanteds in tcSimplify
-    wanteds = filter notFunDep (lieToList wanted_lie)
+    -- JRL nope - it's too early to throw away fundeps here...
+    wanteds = {- filter notFunDep -} (lieToList wanted_lie)
     given_dicts = filter isClassDict givens
 
     try_me inst 
       -- Does not constrain a local tyvar
       | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
-        && (isDict inst || null (getIPs inst))
       = Free
 
       -- When checking against a given signature we always reduce
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 701c15c6f0..a4c97df206 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -39,7 +39,7 @@ import VarSet
 import Digraph		( stronglyConnComp, SCC(..) )
 import Name		( Name, NamedThing(..), getSrcLoc, isTvOcc, nameOccName )
 import Outputable
-import Maybes		( mapMaybe, expectJust )
+import Maybes		( mapMaybe, catMaybes, expectJust )
 import UniqSet		( UniqSet, emptyUniqSet,
 			  unitUniqSet, unionUniqSets, 
 			  unionManyUniqSets, uniqSetToList ) 
@@ -272,7 +272,7 @@ Edges in Type/Class decls
 mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
 
 mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _ _ _)
-  = Just (decl, getUnique name, map (getUnique . get_clas) ctxt)
+  = Just (decl, getUnique name, map getUnique (catMaybes (map get_clas ctxt)))
 mk_cls_edges other_decl
   = Nothing
 
@@ -280,8 +280,8 @@ mk_cls_edges other_decl
 mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique])
 
 mk_edges decl@(TyData _ ctxt name _ condecls derivs _ _)
-  = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets` 
-					 get_cons condecls `unionUniqSets` 
+  = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
+					 get_cons condecls `unionUniqSets`
 					 get_deriv derivs))
 
 mk_edges decl@(TySynonym name _ rhs _)
@@ -293,8 +293,9 @@ mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _ _ _ _)
 
 
 ----------------------------------------------------
-get_ctxt ctxt = unionManyUniqSets (map (set_name . get_clas) ctxt)
-get_clas (HsPClass clas _) = clas
+get_ctxt ctxt = unionManyUniqSets (map set_name (catMaybes (map get_clas ctxt)))
+get_clas (HsPClass clas _) = Just clas
+get_clas _                 = Nothing
 
 ----------------------------------------------------
 get_deriv Nothing     = emptyUniqSet
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 36031cbb95..cf4a69dad8 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -45,7 +45,7 @@ import TyCon		( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon, mkAlgTyCon,
 			)
 import Type		( getTyVar, tyVarsOfTypes, splitFunTy, applyTys,
 			  mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
-			  mkTyVarTy, splitForAllTys, isForAllTy, splitAlgTyConApp_maybe,
+			  mkTyVarTy, splitAlgTyConApp_maybe,
 			  mkArrowKind, mkArrowKinds, boxedTypeKind,
 			  isUnboxedType, Type, ThetaType, classesOfPreds
 			)
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 6ec5e2d841..b54183e97c 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -44,13 +44,13 @@ module Type (
         mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy, 
 
 	mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, 
-	isForAllTy, applyTy, applyTys, mkPiType, hoistForAllTys,
+	applyTy, applyTys, mkPiType, hoistForAllTys,
 
 	TauType, RhoType, SigmaType, PredType(..), ThetaType,
 	ClassPred, ClassContext, mkClassPred,
 	getClassTys_maybe, ipName_maybe, classesToPreds, classesOfPreds,
 	isTauTy, mkRhoTy, splitRhoTy,
-	mkSigmaTy, splitSigmaTy,
+	mkSigmaTy, isSigmaTy, splitSigmaTy,
 
 	-- Lifting and boxity
 	isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
@@ -241,14 +241,17 @@ splitFunTy (FunTy arg res) = (arg, res)
 splitFunTy (NoteTy _ ty)   = splitFunTy ty
 
 splitFunTy_maybe :: Type -> Maybe (Type, Type)
-splitFunTy_maybe (FunTy arg res) = Just (arg, res)
-splitFunTy_maybe (NoteTy _ ty)   = splitFunTy_maybe ty
-splitFunTy_maybe other	         = Nothing
+splitFunTy_maybe (FunTy arg res)	= Just (arg, res)
+splitFunTy_maybe (NoteTy (IPNote _) ty)	= Nothing
+splitFunTy_maybe (NoteTy _ ty)   	= splitFunTy_maybe ty
+splitFunTy_maybe other	         	= Nothing
 
 splitFunTys :: Type -> ([Type], Type)
 splitFunTys ty = split [] ty ty
   where
     split args orig_ty (FunTy arg res) = split (arg:args) res res
+    split args orig_ty (NoteTy (IPNote _) ty)
+				       = (reverse args, orig_ty)
     split args orig_ty (NoteTy _ ty)   = split args orig_ty ty
     split args orig_ty ty              = (reverse args, orig_ty)
 
@@ -304,10 +307,11 @@ mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
 -- including functions are returned as Just ..
 
 splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
-splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
-splitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
-splitTyConApp_maybe (NoteTy _ ty)     = splitTyConApp_maybe ty
-splitTyConApp_maybe other	      = Nothing
+splitTyConApp_maybe (TyConApp tc tys)	   = Just (tc, tys)
+splitTyConApp_maybe (FunTy arg res)	   = Just (funTyCon, [arg,res])
+splitTyConApp_maybe (NoteTy (IPNote _) ty) = Nothing
+splitTyConApp_maybe (NoteTy _ ty)	   = splitTyConApp_maybe ty
+splitTyConApp_maybe other		   = Nothing
 
 -- splitAlgTyConApp_maybe looks for 
 --	*saturated* applications of *algebraic* data types
@@ -318,6 +322,8 @@ splitAlgTyConApp_maybe :: Type -> Maybe (TyCon, [Type], [DataCon])
 splitAlgTyConApp_maybe (TyConApp tc tys) 
   | isAlgTyCon tc && 
     tyConArity tc == length tys      = Just (tc, tys, tyConDataCons tc)
+splitAlgTyConApp_maybe (NoteTy (IPNote _) ty)
+				     = Nothing
 splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
 splitAlgTyConApp_maybe other	     = Nothing
 
@@ -448,6 +454,8 @@ typePrimRep ty = case repType ty of
 splitNewType_maybe :: Type -> Maybe Type
 -- Find the representation of a newtype, if it is one
 -- Looks through multiple levels of newtype, but does not look through for-alls
+splitNewType_maybe (NoteTy (IPNote _) ty)
+				     = Nothing
 splitNewType_maybe (NoteTy _ ty)     = splitNewType_maybe ty
 splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of
 					 Just rep_ty -> ASSERT( length tys == tyConArity tc )
@@ -590,14 +598,10 @@ splitForAllTy_maybe ty = case splitUsgTy_maybe ty of
 					        return (tyvar, NoteTy (UsgNote usg) ty'')
 			   Nothing        -> splitFAT_m ty
   where
-    splitFAT_m (NoteTy _ ty)       = splitFAT_m ty
-    splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
-    splitFAT_m _		   = Nothing
-
-isForAllTy :: Type -> Bool
-isForAllTy (NoteTy _ ty)       = isForAllTy ty
-isForAllTy (ForAllTy tyvar ty) = True
-isForAllTy _		     = False
+    splitFAT_m (NoteTy (IPNote _) ty)	= Nothing
+    splitFAT_m (NoteTy _ ty)		= splitFAT_m ty
+    splitFAT_m (ForAllTy tyvar ty)	= Just(tyvar, ty)
+    splitFAT_m _			= Nothing
 
 splitForAllTys :: Type -> ([TyVar], Type)
 splitForAllTys ty = case splitUsgTy_maybe ty of
@@ -605,9 +609,10 @@ splitForAllTys ty = case splitUsgTy_maybe ty of
 					in  (tvs, NoteTy (UsgNote usg) ty'')
 		      Nothing        -> split ty ty []
    where
-     split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
-     split orig_ty (NoteTy _ ty)    tvs = split orig_ty ty tvs
-     split orig_ty t	            tvs = (reverse tvs, orig_ty)
+     split orig_ty (ForAllTy tv ty)	  tvs = split ty ty (tv:tvs)
+     split orig_ty (NoteTy (IPNote _) ty) tvs = (reverse tvs, orig_ty)
+     split orig_ty (NoteTy _ ty)	  tvs = split orig_ty ty tvs
+     split orig_ty t			  tvs = (reverse tvs, orig_ty)
 \end{code}
 
 @mkPiType@ makes a (->) type or a forall type, depending on whether
@@ -719,12 +724,13 @@ classesOfPreds theta = concatMap cvt theta
 
 \begin{code}
 isTauTy :: Type -> Bool
-isTauTy (TyVarTy v)      = True
-isTauTy (TyConApp _ tys) = all isTauTy tys
-isTauTy (AppTy a b)    	 = isTauTy a && isTauTy b
-isTauTy (FunTy a b)  	 = isTauTy a && isTauTy b
-isTauTy (NoteTy _ ty)  	 = isTauTy ty
-isTauTy other	       	 = False
+isTauTy (TyVarTy v)		= True
+isTauTy (TyConApp _ tys)	= all isTauTy tys
+isTauTy (AppTy a b)		= isTauTy a && isTauTy b
+isTauTy (FunTy a b)		= isTauTy a && isTauTy b
+isTauTy (NoteTy (IPNote _) ty)	= False
+isTauTy (NoteTy _ ty)		= isTauTy ty
+isTauTy other			= False
 \end{code}
 
 \begin{code}
@@ -737,8 +743,9 @@ splitRhoTy ty = split ty ty []
   split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of
 					Just p -> split res res (p:ts)
 					Nothing   -> (reverse ts, orig_ty)
-  split orig_ty (NoteTy _ ty) ts   = split orig_ty ty ts
-  split orig_ty ty ts		   = (reverse ts, orig_ty)
+  split orig_ty (NoteTy (IPNote _) ty)	ts = (reverse ts, orig_ty)
+  split orig_ty (NoteTy _ ty)		ts = split orig_ty ty ts
+  split orig_ty ty			ts = (reverse ts, orig_ty)
 \end{code}
 
 
@@ -746,6 +753,17 @@ splitRhoTy ty = split ty ty []
 \begin{code}
 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
 
+isSigmaTy :: Type -> Bool
+isSigmaTy (FunTy a b)		= isPredTy a
+    where isPredTy (NoteTy (IPNote _) _) = True
+	  -- JRL could be a dict ty, but that would be polymorphic,
+	  -- and thus there would have been an outer ForAllTy
+	  isPredTy _			 = False
+isSigmaTy (NoteTy (IPNote _) _) = False
+isSigmaTy (NoteTy _ ty)		= isSigmaTy ty
+isSigmaTy (ForAllTy tyvar ty)	= True
+isSigmaTy _			= False
+
 splitSigmaTy :: Type -> ([TyVar], [PredType], Type)
 splitSigmaTy ty =
   (tyvars, theta, tau)
@@ -988,6 +1006,5 @@ seqNote :: TyNote -> ()
 seqNote (SynNote ty)  = seqType ty
 seqNote (FTVNote set) = sizeUniqSet set `seq` ()
 seqNote (UsgNote usg) = usg `seq` ()
-seqNote (IPNote nm)    = nm `seq` ()
+seqNote (IPNote nm)   = nm `seq` ()
 \end{code}
-