[project @ 2000-03-25 12:38:40 by panne]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcBinds.lhs

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 55c37dd..69bde88 100644 (file)
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -21,6 +21,7 @@ import TcHsSyn                ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
 import TcMonad
 import Inst            ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
                          newDicts, tyVarsOfInst, instToId,
+                         getAllFunDepsOfLIE, getIPsOfLIE, zonkFunDeps
                        )
 import TcEnv           ( tcExtendLocalValEnv,
                          newSpecPragmaId, newLocalId,
@@ -29,7 +30,7 @@ import TcEnv          ( tcExtendLocalValEnv,
                        )
 import TcSimplify      ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
 import TcImprove       ( tcImprove )
-import TcMonoType      ( tcHsType, checkSigTyVars,
+import TcMonoType      ( tcHsSigType, checkSigTyVars,
                          TcSigInfo(..), tcTySig, maybeSig, sigCtxt
                        )
 import TcPat           ( tcPat )
@@ -45,14 +46,16 @@ import PrelInfo             ( main_NAME, ioTyCon_NAME )
 
 import Id              ( Id, mkVanillaId, setInlinePragma )
 import Var             ( idType, idName )
-import IdInfo          ( IdInfo, vanillaIdInfo, setInlinePragInfo, InlinePragInfo(..) )
+import IdInfo          ( setInlinePragInfo, InlinePragInfo(..) )
 import Name            ( Name, getName, getOccName, getSrcLoc )
 import NameSet
 import Type            ( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
                          splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, 
-                         mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType, 
+                         mkPredTy, splitRhoTy, mkForAllTy, isUnLiftedType, 
                          isUnboxedType, unboxedTypeKind, boxedTypeKind
                        )
+import PprType          ( {- instance Outputable Type -} )
+import FunDeps         ( tyVarFunDep, oclose )
 import Var             ( TyVar, tyVarKind )
 import VarSet
 import Bag
@@ -288,8 +291,9 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
 
        -- SIMPLIFY THE LIE
     tcExtendGlobalTyVars tyvars_not_to_gen (
-       if null real_tyvars_to_gen_list then
-               -- No polymorphism, so no need to simplify context
+       let ips = getIPsOfLIE lie_req in
+       if null real_tyvars_to_gen_list && (null ips || not is_unrestricted) then
+               -- No polymorphism, and no IPs, so no need to simplify context
            returnTc (lie_req, EmptyMonoBinds, [])
        else
        case maybe_sig_theta of
@@ -298,7 +302,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
                -- NB: no signatures => no polymorphic recursion, so no
                -- need to use lie_avail (which will be empty anyway)
            tcSimplify (text "tcBinds1" <+> ppr binder_names)
-                      top_lvl real_tyvars_to_gen lie_req       `thenTc` \ (lie_free, dict_binds, lie_bound) ->
+                      real_tyvars_to_gen lie_req       `thenTc` \ (lie_free, dict_binds, lie_bound) ->
            returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
 
          Just (sig_theta, lie_avail) ->
@@ -406,6 +410,7 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
 
         -- BUILD RESULTS
     returnTc (
+        -- pprTrace "binding.." (ppr ((dicts_bound, dict_binds), exports, [idType poly_id | (_, poly_id, _) <- exports])) $
         AbsBinds real_tyvars_to_gen_list
                  dicts_bound
                  exports
@@ -533,22 +538,27 @@ getTyVarsToGen is_unrestricted mono_id_tys lie
   = tcGetGlobalTyVars                  `thenNF_Tc` \ free_tyvars ->
     zonkTcTypes mono_id_tys            `thenNF_Tc` \ zonked_mono_id_tys ->
     let
-       tyvars_to_gen = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
+       body_tyvars = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
     in
     if is_unrestricted
     then
-       returnNF_Tc (emptyVarSet, tyvars_to_gen)
+       let fds = getAllFunDepsOfLIE lie in
+       zonkFunDeps fds         `thenNF_Tc` \ fds' ->
+       let tvFundep = tyVarFunDep fds'
+           extended_tyvars = oclose tvFundep body_tyvars in
+       -- pprTrace "gTVTG" (ppr (lie, body_tyvars, extended_tyvars)) $
+       returnNF_Tc (emptyVarSet, extended_tyvars)
     else
        -- This recover and discard-errs is to avoid duplicate error
        -- messages; this, after all, is an "extra" call to tcSimplify
-       recoverNF_Tc (returnNF_Tc (emptyVarSet, tyvars_to_gen))         $
+       recoverNF_Tc (returnNF_Tc (emptyVarSet, body_tyvars))           $
        discardErrsTc                                                   $
 
-       tcSimplify (text "getTVG") NotTopLevel tyvars_to_gen lie    `thenTc` \ (_, _, constrained_dicts) ->
+       tcSimplify (text "getTVG") body_tyvars lie    `thenTc` \ (_, _, constrained_dicts) ->
        let
          -- ASSERT: dicts_sig is already zonked!
            constrained_tyvars    = foldrBag (unionVarSet . tyVarsOfInst) emptyVarSet constrained_dicts
-           reduced_tyvars_to_gen = tyvars_to_gen `minusVarSet` constrained_tyvars
+           reduced_tyvars_to_gen = body_tyvars `minusVarSet` constrained_tyvars
         in
         returnTc (constrained_tyvars, reduced_tyvars_to_gen)
 \end{code}
@@ -785,7 +795,7 @@ checkSigMatch top_lvl binder_names mono_ids sigs
        = tcAddSrcLoc src_loc   $
          checkTc (null theta) (mainContextsErr id)
 
-    mk_dict_tys theta = [mkDictTy c ts | (c,ts) <- theta]
+    mk_dict_tys theta = map mkPredTy theta
 
     sig_msg id tidy_ty = sep [ptext SLIT("When checking the type signature"),
                              nest 4 (ppr id <+> dcolon <+> ppr tidy_ty)]
@@ -848,7 +858,7 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
     tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
 
        -- Get and instantiate its alleged specialised type
-    tcHsType poly_ty                           `thenTc` \ sig_ty ->
+    tcHsSigType poly_ty                                `thenTc` \ sig_ty ->
 
        -- Check that f has a more general type, and build a RHS for
        -- the spec-pragma-id at the same time