X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsPat.lhs;h=409e95962cd79d2fd15fa1a5be504e880b41829b;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=aff67627c14859a8dfef1602de44bcfd7b6fa171;hpb=1fb1ab5d53a09607e7f6d2450806760688396387;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index aff6762..409e959 100644
--- a/ghc/compiler/hsSyn/HsPat.lhs
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -1,11 +1,9 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[PatSyntax]{Abstract Haskell syntax---patterns}
 
 \begin{code}
-#include "HsVersions.h"
-
 module HsPat (
 	InPat(..),
 	OutPat(..),
@@ -17,21 +15,20 @@ module HsPat (
 	collectPatBinders
     ) where
 
-IMP_Ubiq()
+#include "HsVersions.h"
 
 -- friends:
-import HsBasic			( HsLit, Fixity )
-IMPORT_DELOOPER(HsLoop)		( HsExpr )
+import HsBasic		( HsLit )
+import HsExpr		( HsExpr )
+import BasicTypes	( Fixity )
 
 -- others:
-import Id		( dataConTyCon, GenId )
+import Var		( Id, GenTyVar )
+import DataCon		( DataCon, dataConTyCon )
 import Maybes		( maybeToBool )
-import Name		( pprSym, pprNonSym )
-import Outputable	( interppSP, interpp'SP, ifPprShowAll )
-import PprStyle		( PprStyle(..) )
-import Pretty
+import Outputable	
 import TyCon		( maybeTyConSingleCon )
-import PprType		( GenType )
+import Type		( GenType )
 \end{code}
 
 Patterns come in distinct before- and after-typechecking flavo(u)rs.
@@ -60,51 +57,54 @@ data InPat name
 
   | ListPatIn	    [InPat name]	-- syntactic list
 					-- must have >= 1 elements
-  | TuplePatIn	    [InPat name]	-- tuple
+  | TuplePatIn	    [InPat name] Bool	-- tuple (boxed?)
 
   | RecPatIn	    name 		-- record
 		    [(name, InPat name, Bool)]	-- True <=> source used punning
 
-data OutPat tyvar uvar id
-  = WildPat	    (GenType tyvar uvar)	-- wild card
+data OutPat flexi id
+  = WildPat	    (GenType flexi)	-- wild card
 
   | VarPat	    id				-- variable (type is in the Id)
 
-  | LazyPat	    (OutPat tyvar uvar id)	-- lazy pattern
+  | LazyPat	    (OutPat flexi id)	-- lazy pattern
 
   | AsPat	    id				-- as pattern
-		    (OutPat tyvar uvar id)
-
-  | ConPat	    Id				-- Constructor is always an Id
-		    (GenType tyvar uvar)    	-- the type of the pattern
-		    [OutPat tyvar uvar id]
+		    (OutPat flexi id)
 
-  | ConOpPat	    (OutPat tyvar uvar id)	-- just a special case...
-		    Id
-		    (OutPat tyvar uvar id)
-		    (GenType tyvar uvar)
   | ListPat		 	    		-- syntactic list
-		    (GenType tyvar uvar)	-- the type of the elements
-   	    	    [OutPat tyvar uvar id]
+		    (GenType flexi)	-- the type of the elements
+   	    	    [OutPat flexi id]
 
-  | TuplePat	    [OutPat tyvar uvar id]	-- tuple
+  | TuplePat	    [OutPat flexi id]	-- tuple
+		    Bool		-- boxed?
 						-- 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
+  | ConPat	    DataCon
+		    (GenType flexi)    	-- the type of the pattern
+		    [GenTyVar flexi]	-- Existentially bound type variables
+		    [id]		-- Ditto dictionaries
+		    [OutPat flexi id]
+
+  -- ConOpPats are only used on the input side
+
+  | RecPat	    DataCon		-- record constructor
+		    (GenType flexi)    	-- the type of the pattern
+		    [GenTyVar flexi]	-- Existentially bound type variables
+		    [id]		-- Ditto dictionaries
+		    [(Id, OutPat flexi id, Bool)]	-- True <=> source used punning
 
   | LitPat	    -- Used for *non-overloaded* literal patterns:
 		    -- Int#, Char#, Int, Char, String, etc.
 		    HsLit
-		    (GenType tyvar uvar) 	-- type of pattern
+		    (GenType flexi) 	-- type of pattern
 
   | NPat	    -- Used for *overloaded* literal patterns
 		    HsLit			-- the literal is retained so that
 						-- the desugarer can readily identify
 						-- equations with identical literal-patterns
-		    (GenType tyvar uvar) 	-- type of pattern, t
-   	    	    (HsExpr tyvar uvar id (OutPat tyvar uvar id))
+		    (GenType flexi) 	-- type of pattern, t
+   	    	    (HsExpr flexi id (OutPat flexi id))
 						-- of type t -> Bool; detects match
 
   | NPlusKPat	    id
@@ -112,115 +112,112 @@ data OutPat tyvar uvar id
 						-- (This could be an Integer, but then
 						-- it's harder to partitionEqnsByLit
 						-- in the desugarer.)
-		    (GenType tyvar uvar)    	-- Type of pattern, t
-   	    	    (HsExpr tyvar uvar id (OutPat tyvar uvar id)) 	-- Of type t -> Bool; detects match
-   	    	    (HsExpr tyvar uvar id (OutPat tyvar uvar id)) 	-- Of type t -> t; subtracts k
+		    (GenType flexi)    	-- Type of pattern, t
+   	    	    (HsExpr flexi id (OutPat flexi id)) 	-- Of type t -> Bool; detects match
+   	    	    (HsExpr flexi id (OutPat flexi id)) 	-- Of type t -> t; subtracts k
 
   | DictPat	    -- Used when destructing Dictionaries with an explicit case
 		    [id]			-- superclass dicts
 		    [id]			-- methods
 \end{code}
 
+Now name in Inpat is not need to be in NAmedThing to be Outputable.
+Needed by ../deSugar/Check.lhs
+
+JJQC-2-12-97
+
 \begin{code}
-instance (Outputable name, NamedThing name) => Outputable (InPat name) where
+instance (Outputable name) => Outputable (InPat name) where
     ppr = pprInPat
 
-pprInPat :: (Outputable name, NamedThing name) => PprStyle -> InPat name -> Pretty
+pprInPat :: (Outputable name) => InPat name -> SDoc
 
-pprInPat sty (WildPatIn)	= ppChar '_'
-pprInPat sty (VarPatIn var)	= ppr sty var
-pprInPat sty (LitPatIn s)	= ppr sty s
-pprInPat sty (LazyPatIn pat)	= ppBeside (ppChar '~') (ppr sty pat)
-pprInPat sty (AsPatIn name pat)
-    = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen]
+pprInPat (WildPatIn)	    = char '_'
+pprInPat (VarPatIn var)	    = ppr var
+pprInPat (LitPatIn s)	    = ppr s
+pprInPat (LazyPatIn pat)    = char '~' <> ppr pat
+pprInPat (AsPatIn name pat) = parens (hcat [ppr name, char '@', ppr pat])
 
-pprInPat sty (ConPatIn c pats)
- = if null pats then
-      ppr sty c
-   else
-      ppCat [ppr sty c, interppSP sty pats] -- ParPats put in the parens
+pprInPat (ConPatIn c pats)
+  | null pats = ppr c
+  | otherwise = hsep [ppr c, interppSP pats] -- ParPats put in the parens
 
-pprInPat sty (ConOpPatIn pat1 op fixity pat2)
- = ppCat [ppr sty pat1, ppr sty op, ppr sty pat2] -- ParPats put in parens
+pprInPat (ConOpPatIn pat1 op fixity pat2)
+ = hsep [ppr pat1, ppr op, ppr 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)
 
-pprInPat sty (NegPatIn pat)
+pprInPat (NegPatIn pat)
   = let
-	pp_pat = pprInPat sty pat
+	pp_pat = pprInPat pat
     in
-    ppBeside (ppChar '-') (
+    char '-' <> (
     case pat of
       LitPatIn _ -> pp_pat
-      _          -> ppParens pp_pat
+      _          -> parens pp_pat
     )
 
-pprInPat sty (ParPatIn pat)
-  = ppParens (pprInPat sty pat)
+pprInPat (ParPatIn pat)
+  = parens (pprInPat pat)
 
-pprInPat sty (ListPatIn pats)
-  = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack]
-pprInPat sty (TuplePatIn pats)
-  = ppParens (interpp'SP sty pats)
-pprInPat sty (NPlusKPatIn n k)
-  = ppBesides [ppLparen, ppr sty n, ppChar '+', ppr sty k, ppRparen]
+pprInPat (ListPatIn pats)
+  = brackets (interpp'SP pats)
+pprInPat (TuplePatIn pats False)
+  = text "(#" <> (interpp'SP pats) <> text "#)"
+pprInPat (TuplePatIn pats True)
+  = parens (interpp'SP pats)
+pprInPat (NPlusKPatIn n k)
+  = parens (hcat [ppr n, char '+', ppr k])
 
-pprInPat sty (RecPatIn con rpats)
-  = ppCat [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))]
+pprInPat (RecPatIn con rpats)
+  = hsep [ppr con, braces (hsep (punctuate comma (map (pp_rpat) rpats)))]
   where
-    pp_rpat PprForUser (v, _, True) = ppr PprForUser v
-    pp_rpat sty        (v, p, _)    = ppCat [ppr sty v, ppChar '=', ppr sty p]
+    pp_rpat (v, _, True) = ppr v
+    pp_rpat (v, p, _)    = hsep [ppr v, char '=', ppr p]
 \end{code}
 
 \begin{code}
-instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, Outputable id)
-       => Outputable (OutPat tyvar uvar id) where
+instance (Outputable id) => Outputable (OutPat flexi id) where
     ppr = pprOutPat
 \end{code}
 
 \begin{code}
-pprOutPat sty (WildPat ty)	= ppChar '_'
-pprOutPat sty (VarPat var)	= ppr sty var
-pprOutPat sty (LazyPat pat)	= ppBesides [ppChar '~', ppr sty pat]
-pprOutPat sty (AsPat name pat)
-  = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen]
-
-pprOutPat sty (ConPat name ty [])
-  = ppBeside (ppr sty name)
-	(ifPprShowAll sty (pprConPatTy sty ty))
-
-pprOutPat sty (ConPat name ty pats)
-  = ppBesides [ppLparen, ppr sty name, ppSP,
-    	 interppSP sty pats, ppRparen,
-    	 ifPprShowAll sty (pprConPatTy sty ty) ]
-
-pprOutPat sty (ConOpPat pat1 op pat2 ty)
-  = ppBesides [ppLparen, ppr sty pat1, ppSP, pprSym sty op, ppSP, ppr sty pat2, ppRparen]
-
-pprOutPat sty (ListPat ty pats)
-  = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack]
-pprOutPat sty (TuplePat pats)
-  = ppParens (interpp'SP sty pats)
-
-pprOutPat sty (RecPat con ty rpats)
-  = ppBesides [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))]
+pprOutPat (WildPat ty)	= char '_'
+pprOutPat (VarPat var)	= ppr var
+pprOutPat (LazyPat pat)	= hcat [char '~', ppr pat]
+pprOutPat (AsPat name pat)
+  = parens (hcat [ppr name, char '@', ppr pat])
+
+pprOutPat (ConPat name ty [] [] [])
+  = ppr name
+
+pprOutPat (ConPat name ty tyvars dicts pats)
+  = parens (hsep [ppr name, interppSP tyvars, interppSP dicts, interppSP pats])
+
+pprOutPat (ListPat ty pats)
+  = brackets (interpp'SP pats)
+pprOutPat (TuplePat pats boxed@True)
+  = parens (interpp'SP pats)
+pprOutPat (TuplePat pats unboxed@False)
+  = text "(#" <> (interpp'SP pats) <> text "#)"
+
+pprOutPat (RecPat con ty tvs dicts rpats)
+  = hsep [ppr con, interppSP tvs, interppSP dicts, braces (hsep (punctuate comma (map (pp_rpat) rpats)))]
   where
-    pp_rpat PprForUser (v, _, True) = ppr PprForUser v
-    pp_rpat sty (v, p, _)           = ppCat [ppr sty v, ppChar '=', ppr sty p]
+    pp_rpat (v, _, True) = ppr v
+    pp_rpat (v, p, _)    = hsep [ppr v, char '=', ppr p]
 
-pprOutPat sty (LitPat l ty) 	= ppr sty l	-- ToDo: print more
-pprOutPat sty (NPat   l ty e)	= ppr sty l	-- ToDo: print more
-pprOutPat sty (NPlusKPat n k ty e1 e2)		-- ToDo: print more
-  = ppBesides [ppLparen, ppr sty n, ppChar '+', ppr sty k, ppRparen]
+pprOutPat (LitPat l ty) 	= ppr l	-- ToDo: print more
+pprOutPat (NPat   l ty e)	= ppr l	-- ToDo: print more
+pprOutPat (NPlusKPat n k ty e1 e2)		-- ToDo: print more
+  = parens (hcat [ppr n, char '+', ppr k])
 
-pprOutPat sty (DictPat dicts methods)
- = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")],
-	  ppBracket (interpp'SP sty dicts),
-	  ppBesides [ppBracket (interpp'SP sty methods), ppRparen]]
+pprOutPat (DictPat dicts methods)
+ = parens (sep [ptext SLIT("{-dict-}"),
+		  brackets (interpp'SP dicts),
+		  brackets (interpp'SP methods)])
 
-pprConPatTy sty ty
- = ppParens (ppr sty ty)
 \end{code}
 
 %************************************************************************
@@ -252,7 +249,7 @@ patterns are treated specially, of course.
 
 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 \begin{code}
-irrefutablePats :: [OutPat a b c] -> Bool
+irrefutablePats :: [OutPat a b] -> Bool
 irrefutablePats pat_list = all irrefutablePat pat_list
 
 irrefutablePat (AsPat	_ pat)	= irrefutablePat pat
@@ -262,17 +259,16 @@ irrefutablePat (LazyPat	_)	= True
 irrefutablePat (DictPat ds ms)	= (length ds + length ms) <= 1
 irrefutablePat other		= False
 
-failureFreePat :: OutPat a b c -> Bool
+failureFreePat :: OutPat a b -> 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 (ConPat con tys _ _ pats)  = only_con con && all failureFreePat pats
+failureFreePat (RecPat con _ _ _ fields)  = only_con con && and [ failureFreePat pat | (_,pat,_) <- fields ]
 failureFreePat (ListPat _ _)		  = False
-failureFreePat (TuplePat pats)		  = all failureFreePat pats
+failureFreePat (TuplePat pats _)	  = all failureFreePat pats
 failureFreePat (DictPat _ _)		  = True
 failureFreePat other_pat		  = False   -- Literals, NPat
 
@@ -280,19 +276,18 @@ only_con con = maybeToBool (maybeTyConSingleCon (dataConTyCon con))
 \end{code}
 
 \begin{code}
-patsAreAllCons :: [OutPat a b c] -> Bool
+patsAreAllCons :: [OutPat a b] -> Bool
 patsAreAllCons pat_list = all isConPat pat_list
 
 isConPat (AsPat _ pat)		= isConPat pat
-isConPat (ConPat _ _ _)		= True
-isConPat (ConOpPat _ _ _ _)	= True
+isConPat (ConPat _ _ _ _ _)	= True
 isConPat (ListPat _ _)		= True
-isConPat (TuplePat _)		= True
-isConPat (RecPat _ _ _)		= True
+isConPat (TuplePat _ _)		= True
+isConPat (RecPat _ _ _ _ _)	= True
 isConPat (DictPat ds ms)	= (length ds + length ms) > 1
 isConPat other			= False
 
-patsAreAllLits :: [OutPat a b c] -> Bool
+patsAreAllLits :: [OutPat a b] -> Bool
 patsAreAllLits pat_list = all isLitPat pat_list
 
 isLitPat (AsPat _ pat)	       = isLitPat pat
@@ -319,6 +314,6 @@ collectPatBinders (ConOpPatIn p1 c f p2) = collectPatBinders p1 ++ collectPatBin
 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 (TuplePatIn pats _)  	 = concat (map collectPatBinders pats)
 collectPatBinders (RecPatIn c fields) 	 = concat (map (\ (f,pat,_) -> collectPatBinders pat) fields)
 \end{code}