[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.

diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index fe95b3c..7f47891 100644 (file)
--- 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 1a36051..b252aca 100644 (file)
--- 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 100a838..81b468f 100644 (file)
--- 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 77e9e42..e814e06 100644 (file)
--- 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 f1467ba..08b2211 100644 (file)
--- 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 701c15c..a4c97df 100644 (file)
--- 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 36031cb..cf4a69d 100644 (file)
--- 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 6ec5e2d..b54183e 100644 (file)
--- 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}
-