X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=18c61917c2bbbf0f332972667e8dce41f778e96a;hb=4a343629ebe5be2c5b27e84c031e38abd81122fa;hp=59ae266473282f94dce35490c7c93482b58dc14b;hpb=a17d329568660592dad5c7668fb09f31ab77cd69;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 59ae266..18c6191 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -475,6 +475,12 @@ checkStrictBinds top_lvl rec_group mbind mono_tys infos
                   (strictBindErr "Recursive" unlifted mbind)
         ; checkTc (isSingletonBag mbind)
                   (strictBindErr "Multiple" unlifted mbind) 
+        -- This should be a checkTc, not a warnTc, but as of GHC 6.11
+        -- the versions of alex and happy available have non-conforming
+        -- templates, so the GHC build fails if it's an error:
+        ; warnUnlifted <- doptM Opt_WarnLazyUnliftedBindings
+        ; warnTc (warnUnlifted && not bang_pat)
+                 (unliftedMustBeBang mbind)
         ; mapM_ check_sig infos
         ; return True }
   | otherwise
@@ -486,6 +492,12 @@ checkStrictBinds top_lvl rec_group mbind mono_tys infos
                                          (badStrictSig unlifted sig)
     check_sig _                = return ()
 
+unliftedMustBeBang :: LHsBindsLR Var Var -> SDoc
+unliftedMustBeBang mbind
+  = hang (text "Bindings containing unlifted types must use an outermost bang pattern:")
+         4 (pprLHsBinds mbind)
+ $$ text "*** This will be an error in GHC 6.14! Fix your code now!"
+
 strictBindErr :: String -> Bool -> LHsBindsLR Var Var -> SDoc
 strictBindErr flavour unlifted mbind
   = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) 
@@ -724,7 +736,7 @@ generalise :: DynFlags -> TopLevelFlag
 -- The returned [TyVar] are all ready to quantify
 
 generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
-  | isMonoGroup dflags bind_list
+  | isMonoGroup dflags top_lvl bind_list sigs
   = do  { extendLIEs lie_req
         ; return ([], [], emptyBag) }
 
@@ -1147,10 +1159,12 @@ tcInstSig use_skols name
                               sig_loc = loc }) }
 
 -------------------
-isMonoGroup :: DynFlags -> [LHsBind Name] -> Bool
+isMonoGroup :: DynFlags -> TopLevelFlag -> [LHsBind Name]
+            -> [TcSigInfo] ->  Bool
 -- No generalisation at all
-isMonoGroup dflags binds
-  = dopt Opt_MonoPatBinds dflags && any is_pat_bind binds
+isMonoGroup dflags top_lvl binds sigs
+  =  (dopt Opt_MonoPatBinds dflags && any is_pat_bind binds)
+  || (dopt Opt_MonoLocalBinds dflags && null sigs && not (isTopLevel top_lvl))
   where
     is_pat_bind (L _ (PatBind {})) = True
     is_pat_bind _                  = False