X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;fp=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=c765699b9ec4df932ce3a09d4aa90fc1f23df451;hb=5d3051c66796dcf884b052f9e4afc3ed19b9f514;hp=38f4306e06a751819ab122ff31f83820bb20a8a8;hpb=7985849b10db59b566d1864075b97b5d11d3a31d;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 38f4306..c765699 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -22,7 +22,7 @@ import HsSyn		( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..),
 			  HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames, 
 			  isVanillaLSig, sigName, placeHolderNames, isPragLSig,
 			  LPat, GRHSs, MatchGroup(..), pprLHsBinds, mkHsCoerce,
-			  collectHsBindBinders, collectPatBinders, pprPatBind
+			  collectHsBindBinders, collectPatBinders, pprPatBind, isBangHsBind
 			)
 import TcHsSyn		( zonkId )
 
@@ -347,11 +347,11 @@ tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds
 	-- These must be non-recursive etc, and are not generalised
 	-- They desugar to a case expression in the end
   ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos)
-  ; if any isUnLiftedType zonked_mono_tys then
-    do	{ 	-- Unlifted bindings
-	  checkUnliftedBinds top_lvl rec_group binds' mono_bind_infos
-	; extendLIEs lie_req
-	; let exports  = zipWith mk_export mono_bind_infos zonked_mono_tys
+  ; is_strict <- checkStrictBinds top_lvl rec_group binds' 
+				  zonked_mono_tys mono_bind_infos
+  ; if is_strict then
+    do	{ extendLIEs lie_req
+	; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys
 	      mk_export (name, Nothing,  mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, [])
 	      mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig,             mono_id, [])
 			-- ToDo: prags for unlifted bindings
@@ -469,20 +469,40 @@ forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
 --	b) not top level, 
 --	c) not a multiple-binding group (more or less implied by (a))
 
-checkUnliftedBinds :: TopLevelFlag -> RecFlag
-		   -> LHsBinds TcId -> [MonoBindInfo] -> TcM ()
-checkUnliftedBinds top_lvl rec_group mbind infos
+checkStrictBinds :: TopLevelFlag -> RecFlag
+		 -> LHsBinds TcId -> [TcType] -> [MonoBindInfo]
+		 -> TcM Bool
+checkStrictBinds top_lvl rec_group mbind mono_tys infos
+  | unlifted || bang_pat
   = do 	{ checkTc (isNotTopLevel top_lvl)
-	  	  (unliftedBindErr "Top-level" mbind)
+	  	  (strictBindErr "Top-level" unlifted mbind)
 	; checkTc (isNonRec rec_group)
-	  	  (unliftedBindErr "Recursive" mbind)
+	  	  (strictBindErr "Recursive" unlifted mbind)
 	; checkTc (isSingletonBag mbind)
-	    	  (unliftedBindErr "Multiple" mbind) 
-	; mapM_ check_sig infos }
+	    	  (strictBindErr "Multiple" unlifted mbind) 
+	; mapM_ check_sig infos
+	; return True }
+  | otherwise
+  = return False
   where
+    unlifted = any isUnLiftedType mono_tys
+    bang_pat = anyBag (isBangHsBind . unLoc) mbind
     check_sig (_, Just sig, _) = checkTc (null (sig_tvs sig) && null (sig_theta sig))
-					 (badUnliftedSig sig)
+					 (badStrictSig unlifted sig)
     check_sig other	       = return ()
+
+strictBindErr flavour unlifted mbind
+  = hang (text flavour <+> msg <+> ptext SLIT("aren't allowed:")) 4 (ppr mbind)
+  where
+    msg | unlifted  = ptext SLIT("bindings for unlifted types")
+	| otherwise = ptext SLIT("bang-pattern bindings")
+
+badStrictSig unlifted sig
+  = hang (ptext SLIT("Illegal polymorphic signature in") <+> msg)
+	 4 (ppr sig)
+  where
+    msg | unlifted  = ptext SLIT("an unlifted binding")
+	| otherwise = ptext SLIT("a bang-pattern binding")
 \end{code}
 
 
@@ -498,9 +518,9 @@ The signatures have been dealt with already.
 \begin{code}
 tcMonoBinds :: [LHsBind Name]
 	    -> TcSigFun
-	    -> RecFlag	-- True <=> the binding is recursive for typechecking purposes
-			-- 	    i.e. the binders are mentioned in their RHSs, and
-			--		 we are not resuced by a type signature
+	    -> RecFlag	-- Whether the binding is recursive for typechecking purposes
+			-- i.e. the binders are mentioned in their RHSs, and
+			--	we are not resuced by a type signature
 	    -> TcM (LHsBinds TcId, [MonoBindInfo])
 
 tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, 
@@ -1083,15 +1103,6 @@ sigContextsCtxt sig1 sig2
 
 
 -----------------------------------------------
-unliftedBindErr flavour mbind
-  = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:"))
-	 4 (ppr mbind)
-
-badUnliftedSig sig
-  = hang (ptext SLIT("Illegal polymorphic signature in an unlifted binding"))
-	 4 (ppr sig)
-
------------------------------------------------
 unboxedTupleErr name ty
   = hang (ptext SLIT("Illegal binding of unboxed tuple"))
 	 4 (ppr name <+> dcolon <+> ppr ty)