[project @ 1998-09-30 07:54:05 by sof]

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

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index f711ef7..1552e54 100644 (file)
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -268,11 +268,11 @@ tcBindWithSigs top_lvl binder_names mbind tc_ty_sigs is_rec prag_info_fn
        -- The tyvars_not_to_gen are free in the environment, and hence
        -- candidates for generalisation, but sometimes the monomorphism
        -- restriction means we can't generalise them nevertheless
-    getTyVarsToGen is_unrestricted mono_id_tys lie     `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
+    getTyVarsToGen is_unrestricted mono_id_tys lie     `thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
 
        -- DEAL WITH TYPE VARIABLE KINDS
        -- **** This step can do unification => keep other zonking after this ****
-    mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen)       `thenTc` \ real_tyvars_to_gen_list ->
+    mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen)  `thenTc` \ real_tyvars_to_gen_list ->
     let
        real_tyvars_to_gen = mkTyVarSet real_tyvars_to_gen_list
                -- It's important that the final list 
@@ -337,16 +337,17 @@ tcBindWithSigs top_lvl binder_names mbind tc_ty_sigs is_rec prag_info_fn
        mk_export binder_name mono_id zonked_mono_id_ty
          = (tyvars, TcId (replaceIdInfo poly_id (prag_info_fn binder_name)), TcId mono_id)
          where
-           (tyvars, poly_id) = case maybeSig tc_ty_sigs binder_name of
-                                 Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _) -> (sig_tyvars, sig_poly_id)
-                                 Nothing ->                            (real_tyvars_to_gen_list, new_poly_id)
+           (tyvars, poly_id) = 
+               case maybeSig tc_ty_sigs binder_name of
+                 Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _) -> (sig_tyvars, sig_poly_id)
+                 Nothing ->                            (real_tyvars_to_gen_list, new_poly_id)
 
            new_poly_id = mkUserId binder_name poly_ty
-           poly_ty     = mkForAllTys real_tyvars_to_gen_list $ mkFunTys dict_tys $ zonked_mono_id_ty
-                               -- It's important to build a fully-zonked poly_ty, because
-                               -- we'll slurp out its free type variables when extending the
-                               -- local environment (tcExtendLocalValEnv); if it's not zonked
-                               -- it appears to have free tyvars that aren't actually free at all.
+           poly_ty     = mkForAllTys real_tyvars_to_gen_list $ mkFunTys dict_tys zonked_mono_id_ty
+                       -- It's important to build a fully-zonked poly_ty, because
+                       -- we'll slurp out its free type variables when extending the
+                       -- local environment (tcExtendLocalValEnv); if it's not zonked
+                       -- it appears to have free tyvars that aren't actually free at all.
     in
 
         -- BUILD RESULTS
@@ -487,8 +488,13 @@ getTyVarsToGen is_unrestricted mono_id_tys lie
     in
     if is_unrestricted
     then
-       returnTc (emptyTyVarSet, tyvars_to_gen)
+       returnNF_Tc (emptyTyVarSet, tyvars_to_gen)
     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 (emptyTyVarSet, tyvars_to_gen))       $
+       discardErrsTc                                                   $
+
        tcSimplify (text "getTVG") NotTopLevel tyvars_to_gen lie    `thenTc` \ (_, _, constrained_dicts) ->
        let
          -- ASSERT: dicts_sig is already zonked!
@@ -859,6 +865,9 @@ tcPragmaSig (SpecInstSig _ _) = returnTc (Nothing, EmptyMonoBinds, emptyLIE)
 tcPragmaSig (InlineSig name loc)
   = returnTc (Just (name, setInlinePragInfo IWantToBeINLINEd), EmptyMonoBinds, emptyLIE)
 
+tcPragmaSig (NoInlineSig name loc)
+  = returnTc (Just (name, setInlinePragInfo IDontWantToBeINLINEd), EmptyMonoBinds, emptyLIE)
+
 tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
   =    -- SPECIALISE f :: forall b. theta => tau  =  g
     tcAddSrcLoc src_loc                                $