[project @ 2002-09-09 12:50:26 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 7cda6b9..c6ca52d 100644 (file)
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -34,9 +34,9 @@ import TcMonoType     ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..),
 import TcPat           ( tcPat, tcSubPat, tcMonoPatBndr )
 import TcSimplify      ( bindInstsOfLocalFuns )
 import TcMType         ( newTyVar, newTyVarTy, newHoleTyVarTy,
-                         zonkTcTyVarToTyVar
+                         zonkTcTyVarToTyVar, readHoleResult
                        )
-import TcType          ( mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, 
+import TcType          ( TcTyVar, mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, 
                          mkPredTy, mkForAllTy, isUnLiftedType, 
                          unliftedTypeKind, liftedTypeKind, openTypeKind, eqKind
                        )
@@ -262,13 +262,16 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
        dict_tys = map idType zonked_dict_ids
 
        inlines    = mkNameSet [name | InlineSig True name _ loc <- inline_sigs]
-        no_inlines = listToFM [(name, phase) | InlineSig _ name phase _ <- inline_sigs, 
-                                              not (isAlwaysActive phase)]
+                       -- Any INLINE sig (regardless of phase control) 
+                       -- makes the RHS look small
+        inline_phases = listToFM [(name, phase) | InlineSig _ name phase _ <- inline_sigs, 
+                                                 not (isAlwaysActive phase)]
+                       -- Set the IdInfo field to control the inline phase
                        -- AlwaysActive is the default, so don't bother with them
 
        mk_export binder_name zonked_mono_id
          = (tyvars, 
-            attachNoInlinePrag no_inlines poly_id,
+            attachInlinePhase inline_phases poly_id,
             zonked_mono_id)
          where
            (tyvars, poly_id) = 
@@ -313,8 +316,8 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
        lie_free, poly_ids
     )
 
-attachNoInlinePrag no_inlines bndr
-  = case lookupFM no_inlines (idName bndr) of
+attachInlinePhase inline_phases bndr
+  = case lookupFM inline_phases (idName bndr) of
        Just prag -> bndr `setInlinePragma` prag
        Nothing   -> bndr
 
@@ -430,16 +433,16 @@ generalise binder_names mbind tau_tvs lie_req sigs =
     tcSimplifyRestricted doc tau_tvs lie_req           `thenTc` \ (qtvs, lie_free, binds) ->
 
        -- Check that signature type variables are OK
-    checkSigsTyVars sigs                               `thenTc_`
+    checkSigsTyVars qtvs sigs                          `thenTc` \ final_qtvs ->
 
-    returnTc (qtvs, lie_free, binds, [])
+    returnTc (final_qtvs, lie_free, binds, [])
 
   else if null sigs then       -- UNRESTRICTED CASE, NO TYPE SIGS
     tcSimplifyInfer doc tau_tvs lie_req
 
   else                                 -- UNRESTRICTED CASE, WITH TYPE SIGS
        -- CHECKING CASE: Unrestricted group, there are type signatures
-       -- Check signature contexts are empty 
+       -- Check signature contexts are identical
     checkSigsCtxts sigs                        `thenTc` \ (sig_avails, sig_dicts) ->
     
        -- Check that the needed dicts can be
@@ -447,9 +450,9 @@ generalise binder_names mbind tau_tvs lie_req sigs =
     tcSimplifyInferCheck doc tau_tvs sig_avails lie_req        `thenTc` \ (forall_tvs, lie_free, dict_binds) ->
        
        -- Check that signature type variables are OK
-    checkSigsTyVars sigs                                       `thenTc_`
+    checkSigsTyVars forall_tvs sigs                    `thenTc` \ final_qtvs ->
 
-    returnTc (forall_tvs, lie_free, dict_binds, sig_dicts)
+    returnTc (final_qtvs, lie_free, dict_binds, sig_dicts)
 
   where
     tysig_names = map (idName . tcSigPolyId) sigs
@@ -488,7 +491,23 @@ checkSigsCtxts sigs@(TySigInfo id1 sig_tvs theta1 _ _ _ src_loc : other_sigs)
         checkTc (equalLength theta theta1) sigContextsErr      `thenTc_`
         unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
 
-checkSigsTyVars sigs = mapTc_ check_one sigs
+checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
+checkSigsTyVars qtvs sigs 
+  = mapTc check_one sigs       `thenTc` \ sig_tvs_s ->
+    let
+       -- Sigh.  Make sure that all the tyvars in the type sigs
+       -- appear in the returned ty var list, which is what we are
+       -- going to generalise over.  Reason: we occasionally get
+       -- silly types like
+       --      type T a = () -> ()
+       --      f :: T a
+       --      f () = ()
+       -- Here, 'a' won't appear in qtvs, so we have to add it
+
+       sig_tvs = foldr (unionVarSet . mkVarSet) emptyVarSet sig_tvs_s
+       all_tvs = mkVarSet qtvs `unionVarSet` sig_tvs
+    in
+    returnTc (varSetElems all_tvs)
   where
     check_one (TySigInfo id sig_tyvars sig_theta sig_tau _ _ src_loc)
       = tcAddSrcLoc src_loc                                            $
@@ -647,7 +666,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
        let
           bndr_ty         = idType bndr_id
           complete_it xve = tcAddSrcLoc locn                           $
-                            tcMatchesFun xve name bndr_ty  matches     `thenTc` \ (matches', lie) ->
+                            tcMatchesFun xve name bndr_ty matches      `thenTc` \ (matches', lie) ->
                             returnTc (FunMonoBind bndr_id inf matches' locn, lie)
        in
        returnTc (complete_it, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
@@ -665,11 +684,12 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
                -- so we don't have to do anything here.
 
        tcPat tc_pat_bndr pat pat_ty            `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
+       readHoleResult pat_ty                   `thenTc` \ pat_ty' ->
        let
           complete_it xve = tcAddSrcLoc locn                           $
                             tcAddErrCtxt (patMonoBindsCtxt bind)       $
                             tcExtendLocalValEnv2 xve                   $
-                            tcGRHSs PatBindRhs grhss pat_ty            `thenTc` \ (grhss', lie) ->
+                            tcGRHSs PatBindRhs grhss pat_ty'           `thenTc` \ (grhss', lie) ->
                             returnTc (PatMonoBind pat' grhss' locn, lie)
        in
        returnTc (complete_it, lie_req, tvs, ids, lie_avail)
@@ -689,7 +709,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec
                   tcMonoPatBndr bndr_name pat_ty
 
            Just sig -> tcAddSrcLoc (getSrcLoc name)            $
-                       tcSubPat pat_ty (idType mono_id)        `thenTc` \ (co_fn, lie) ->
+                       tcSubPat (idType mono_id) pat_ty        `thenTc` \ (co_fn, lie) ->
                        returnTc (co_fn, lie, mono_id)
                     where
                        mono_id = tcSigMonoId sig