X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FhsSyn%2FHsPat.lhs;h=5cb26fac2b3f139d278df9ed674ccf49aea30311;hb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;hp=96d308229dc4a2a5838c90d1ee72778190a90dca;hpb=30cf375e0bc79a6b71074a5e0fd2ec393241a751;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index 96d3082..5cb26fa 100644
--- a/ghc/compiler/hsSyn/HsPat.lhs
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -10,21 +10,21 @@ module HsPat (
 	InPat(..),
 	OutPat(..),
 
-	unfailablePats, unfailablePat,
+	irrefutablePat, irrefutablePats,
+	failureFreePat,
 	patsAreAllCons, isConPat,
 	patsAreAllLits,	isLitPat,
-	irrefutablePat,
 	collectPatBinders
     ) where
 
-import Ubiq
+IMP_Ubiq()
 
 -- friends:
 import HsLit		( HsLit )
-import HsLoop		( HsExpr )
+IMPORT_DELOOPER(HsLoop)		( HsExpr )
 
 -- others:
-import Id		( GenId, dataConSig )
+import Id		( dataConTyCon, GenId )
 import Maybes		( maybeToBool )
 import Name		( pprSym, pprNonSym )
 import Outputable	( interppSP, interpp'SP, ifPprShowAll )
@@ -234,17 +234,36 @@ At least the numeric ones may be overloaded.
 A pattern is in {\em exactly one} of the above three categories; `as'
 patterns are treated specially, of course.
 
+The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 \begin{code}
-unfailablePats :: [OutPat a b c] -> Bool
-unfailablePats pat_list = all unfailablePat pat_list
-
-unfailablePat (AsPat	_ pat)	= unfailablePat pat
-unfailablePat (WildPat	_)	= True
-unfailablePat (VarPat	_)	= True
-unfailablePat (LazyPat	_)	= True
-unfailablePat (DictPat ds ms)	= (length ds + length ms) <= 1
-unfailablePat other		= False
+irrefutablePats :: [OutPat a b c] -> Bool
+irrefutablePats pat_list = all irrefutablePat pat_list
+
+irrefutablePat (AsPat	_ pat)	= irrefutablePat pat
+irrefutablePat (WildPat	_)	= True
+irrefutablePat (VarPat	_)	= True
+irrefutablePat (LazyPat	_)	= True
+irrefutablePat (DictPat ds ms)	= (length ds + length ms) <= 1
+irrefutablePat other		= False
+
+failureFreePat :: OutPat a b c -> Bool
+
+failureFreePat (WildPat _) 		  = True
+failureFreePat (VarPat _)  		  = True
+failureFreePat (LazyPat	_) 		  = True
+failureFreePat (AsPat _ pat)		  = failureFreePat pat
+failureFreePat (ConPat con tys pats)	  = only_con con && all failureFreePat pats
+failureFreePat (ConOpPat pat1 con pat2 _) = only_con con && failureFreePat pat1 && failureFreePat pat1
+failureFreePat (RecPat con _ fields)	  = only_con con && and [ failureFreePat pat | (_,pat,_) <- fields ]
+failureFreePat (ListPat _ _)		  = False
+failureFreePat (TuplePat pats)		  = all failureFreePat pats
+failureFreePat (DictPat _ _)		  = True
+failureFreePat other_pat		  = False   -- Literals, NPat
+
+only_con con = maybeToBool (maybeTyConSingleCon (dataConTyCon con))
+\end{code}
 
+\begin{code}
 patsAreAllCons :: [OutPat a b c] -> Bool
 patsAreAllCons pat_list = all isConPat pat_list
 
@@ -266,28 +285,6 @@ isLitPat (NPat   _ _ _)	= True
 isLitPat other		= False
 \end{code}
 
-A pattern is irrefutable if a match on it cannot fail
-(at any depth).
-\begin{code}
-irrefutablePat :: OutPat a b c -> Bool
-
-irrefutablePat (WildPat _) 		  = True
-irrefutablePat (VarPat _)  		  = True
-irrefutablePat (LazyPat	_) 		  = True
-irrefutablePat (AsPat _ pat)		  = irrefutablePat pat
-irrefutablePat (ConPat con tys pats)	  = only_con con && all irrefutablePat pats
-irrefutablePat (ConOpPat pat1 con pat2 _) = only_con con && irrefutablePat pat1 && irrefutablePat pat1
-irrefutablePat (RecPat con _ fields)	  = only_con con && and [ irrefutablePat pat | (_,pat,_) <- fields ]
-irrefutablePat (ListPat _ _)		  = False
-irrefutablePat (TuplePat pats)		  = all irrefutablePat pats
-irrefutablePat (DictPat _ _)		  = True
-irrefutablePat other_pat		  = False   -- Literals, NPat
-
-only_con con = maybeToBool (maybeTyConSingleCon tycon)
- 	       where
-		 (_,_,_,tycon) = dataConSig con
-\end{code}
-
 This function @collectPatBinders@ works with the ``collectBinders''
 functions for @HsBinds@, etc.  The order in which the binders are
 collected is important; see @HsBinds.lhs@.