X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsPat.lhs;h=5cb26fac2b3f139d278df9ed674ccf49aea30311;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=0161813eaca78f56d54a603d2db33e3e17ccc7a0;hpb=2f51f1402e6869c0f049ffbe7b019bf6ab80558f;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index 0161813..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 )
@@ -62,7 +62,7 @@ data InPat name
 		    [(name, InPat name, Bool)]	-- True <=> source used punning
 
 data OutPat tyvar uvar id
-  = WildPat	    (GenType tyvar uvar)	 	    	-- wild card
+  = WildPat	    (GenType tyvar uvar)	-- wild card
 
   | VarPat	    id				-- variable (type is in the Id)
 
@@ -73,7 +73,7 @@ data OutPat tyvar uvar id
 
   | ConPat	    Id				-- Constructor is always an Id
 		    (GenType tyvar uvar)    	-- the type of the pattern
-		    [(OutPat tyvar uvar id)]
+		    [OutPat tyvar uvar id]
 
   | ConOpPat	    (OutPat tyvar uvar id)	-- just a special case...
 		    Id
@@ -81,14 +81,14 @@ data OutPat tyvar uvar id
 		    (GenType tyvar uvar)
   | ListPat		 	    		-- syntactic list
 		    (GenType tyvar uvar)	-- the type of the elements
-   	    	    [(OutPat tyvar uvar id)]
+   	    	    [OutPat tyvar uvar id]
 
-  | TuplePat	    [(OutPat tyvar uvar id)]	-- tuple
+  | TuplePat	    [OutPat tyvar uvar id]	-- tuple
 						-- UnitPat is TuplePat []
 
   | RecPat	    Id 				-- record constructor
 		    (GenType tyvar uvar)    	-- the type of the pattern
-		    [(id, OutPat tyvar uvar id, Bool)]	-- True <=> source used punning
+		    [(Id, OutPat tyvar uvar id, Bool)]	-- True <=> source used punning
 
   | LitPat	    -- Used for *non-overloaded* literal patterns:
 		    -- Int#, Char#, Int, Char, String, etc.
@@ -103,7 +103,7 @@ data OutPat tyvar uvar id
    	    	    (HsExpr tyvar uvar id (OutPat tyvar uvar id))
 						-- of type t -> Bool; detects match
 
-  |  DictPat	    -- Used when destructing Dictionaries with an explicit case
+  | DictPat	    -- Used when destructing Dictionaries with an explicit case
 		    [id]			-- superclass dicts
 		    [id]			-- methods
 \end{code}
@@ -125,11 +125,10 @@ pprInPat sty (ConPatIn c pats)
  = if null pats then
       ppr sty c
    else
-      ppBesides [ppLparen, ppr sty c, ppSP, interppSP sty pats, ppRparen]
-
+      ppCat [ppr sty c, interppSP sty pats] -- ParPats put in the parens
 
 pprInPat sty (ConOpPatIn pat1 op pat2)
- = ppBesides [ppLparen, ppr sty pat1, ppSP, ppr sty op, ppSP, ppr sty pat2, ppRparen]
+ = ppCat [ppr sty pat1, ppr sty op, ppr sty pat2] -- ParPats put in parens
 
 	-- ToDo: use pprSym to print op (but this involves fiddling various
 	-- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP)
@@ -150,13 +149,13 @@ pprInPat sty (ParPatIn pat)
 pprInPat sty (ListPatIn pats)
   = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack]
 pprInPat sty (TuplePatIn pats)
-  = ppBesides [ppLparen, interpp'SP sty pats, ppRparen]
+  = ppParens (interpp'SP sty pats)
 
 pprInPat sty (RecPatIn con rpats)
-  = ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map pp_rpat rpats), ppChar '}']
+  = ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}']
   where
-    pp_rpat (v, _, True{-pun-}) = ppr sty v
-    pp_rpat (v, p, _) = ppCat [ppr sty v, ppStr "<-", ppr sty p]
+    pp_rpat PprForUser (v, _, True) = ppr PprForUser v
+    pp_rpat sty        (v, p, _)    = ppCat [ppr sty v, ppStr "=", ppr sty p]
 \end{code}
 
 \begin{code}
@@ -188,13 +187,13 @@ pprOutPat sty (ConOpPat pat1 op pat2 ty)
 pprOutPat sty (ListPat ty pats)
   = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack]
 pprOutPat sty (TuplePat pats)
-  = ppBesides [ppLparen, interpp'SP sty pats, ppRparen]
+  = ppParens (interpp'SP sty pats)
 
 pprOutPat sty (RecPat con ty rpats)
-  = ppBesides [ppr sty con, ppChar '{', ppInterleave ppComma (map pp_rpat rpats), ppChar '}']
+  = ppBesides [ppr sty con, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}']
   where
---  pp_rpat (v, _, True{-pun-}) = ppr sty v
-    pp_rpat (v, p, _) = ppBesides [ppr sty v, ppStr "<-", ppr sty p]
+    pp_rpat PprForUser (v, _, True) = ppr PprForUser v
+    pp_rpat sty (v, p, _)           = ppCat [ppr sty v, ppStr "=", ppr sty p]
 
 pprOutPat sty (LitPat l ty) 	= ppr sty l	-- ToDo: print more
 pprOutPat sty (NPat   l ty e)	= ppr sty l	-- ToDo: print more
@@ -235,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
 
@@ -254,6 +272,7 @@ isConPat (ConPat _ _ _)		= True
 isConPat (ConOpPat _ _ _ _)	= True
 isConPat (ListPat _ _)		= True
 isConPat (TuplePat _)		= True
+isConPat (RecPat _ _ _)		= True
 isConPat (DictPat ds ms)	= (length ds + length ms) > 1
 isConPat other			= False
 
@@ -266,41 +285,22 @@ 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)	  = all irrefutablePat pats && only_con con
-irrefutablePat (ConOpPat pat1 con pat2 _) = irrefutablePat pat1 && irrefutablePat pat1 && only_con con
-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@.
 \begin{code}
 collectPatBinders :: InPat a -> [a]
 
-collectPatBinders (VarPatIn var)     = [var]
-collectPatBinders (LazyPatIn pat)    = collectPatBinders pat
-collectPatBinders (AsPatIn a pat)    = a : collectPatBinders pat
-collectPatBinders (ConPatIn c pats)  = concat (map collectPatBinders pats)
+collectPatBinders WildPatIn	      = []
+collectPatBinders (VarPatIn var)      = [var]
+collectPatBinders (LitPatIn _)	      = []
+collectPatBinders (LazyPatIn pat)     = collectPatBinders pat
+collectPatBinders (AsPatIn a pat)     = a : collectPatBinders pat
+collectPatBinders (ConPatIn c pats)   = concat (map collectPatBinders pats)
 collectPatBinders (ConOpPatIn p1 c p2)= collectPatBinders p1 ++ collectPatBinders p2
-collectPatBinders (NegPatIn  pat)    = collectPatBinders pat
-collectPatBinders (ParPatIn  pat)    = collectPatBinders pat
-collectPatBinders (ListPatIn pats)   = concat (map collectPatBinders pats)
-collectPatBinders (TuplePatIn pats)  = concat (map collectPatBinders pats)
-collectPatBinders any_other_pat	     = [ {-no binders-} ]
+collectPatBinders (NegPatIn  pat)     = collectPatBinders pat
+collectPatBinders (ParPatIn  pat)     = collectPatBinders pat
+collectPatBinders (ListPatIn pats)    = concat (map collectPatBinders pats)
+collectPatBinders (TuplePatIn pats)   = concat (map collectPatBinders pats)
+collectPatBinders (RecPatIn c fields) = concat (map (\ (f,pat,_) -> collectPatBinders pat) fields)
 \end{code}