X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsPat.lhs;h=c025a8dc35627b0619d0a9cef24a5b0643a82358;hp=e87a6a27b446ba774fc223b3923dcb6fceffb5d8;hb=127d259f77deda6f03c2213c3dacba0354b37322;hpb=a1895147d4d0480f65535c99488ba25873e97bff

diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index e87a6a2..c025a8d 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -11,6 +11,7 @@
 -- any warnings in the module. See
 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
+{-# LANGUAGE DeriveDataTypeable #-}
 
 module HsPat (
 	Pat(..), InPat, OutPat, LPat, 
@@ -19,13 +20,13 @@ module HsPat (
 	HsConPatDetails, hsConPatArgs, 
 	HsRecFields(..), HsRecField(..), hsRecFields,
 
-	HsQuasiQuote(..),
-
 	mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat, mkCoPatCoI,
 
 	isBangHsBind, hsPatNeedsParens,
 	patsAreAllCons, isConPat, isSigPat, isWildPat,
-	patsAreAllLits,	isLitPat, isIrrefutableHsPat, hasViewPat
+	patsAreAllLits,	isLitPat, isIrrefutableHsPat,
+
+	pprParendLPat
     ) where
 
 import {-# SOURCE #-} HsExpr		(SyntaxExpr, LHsExpr, pprLExpr)
@@ -46,6 +47,8 @@ import Outputable
 import Type
 import SrcLoc
 import FastString
+-- libraries:
+import Data.Data hiding (TyCon)
 \end{code}
 
 
@@ -151,6 +154,7 @@ data Pat id
 	    	Type			-- Type of whole pattern, t1
 	-- During desugaring a (CoPat co pat) turns into a cast with 'co' on 
 	-- the scrutinee, followed by a match on 'pat'
+  deriving (Data, Typeable)
 \end{code}
 
 HsConDetails is use for patterns/expressions *and* for data type declarations
@@ -160,6 +164,7 @@ data HsConDetails arg rec
   = PrefixCon [arg]             -- C p1 p2 p3
   | RecCon    rec		-- C { x = p1, y = p2 }
   | InfixCon  arg arg		-- p1 `C` p2
+  deriving (Data, Typeable)
 
 type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id))
 
@@ -177,51 +182,45 @@ data HsRecFields id arg 	-- A bunch of record fields
 				--	{ x = 3, y = True }
 	-- Used for both expressions and patterns
   = HsRecFields { rec_flds   :: [HsRecField id arg],
-		  rec_dotdot :: Maybe Int }
-	-- Nothing => the normal case
-	-- Just n  => the group uses ".." notation, 
-	--		and the first n elts of rec_flds
-	--		were the user-written ones
-	-- (In the latter case, the remaining elts of
-	--  rec_flds are the non-user-written ones)
+		  rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
+  deriving (Data, Typeable)
+
+-- Note [DotDot fields]
+-- ~~~~~~~~~~~~~~~~~~~~
+-- The rec_dotdot field means this:
+--   Nothing => the normal case
+--   Just n  => the group uses ".." notation, 
+--
+-- In the latter case: 
+--
+--   *before* renamer: rec_flds are exactly the n user-written fields
+--
+--   *after* renamer:  rec_flds includes *all* fields, with 
+--   	     	       the first 'n' being the user-written ones
+--		       and the remainder being 'filled in' implicitly
 
 data HsRecField id arg = HsRecField {
 	hsRecFieldId  :: Located id,
-	hsRecFieldArg :: arg,
+	hsRecFieldArg :: arg,		-- Filled in by renamer
 	hsRecPun      :: Bool 		-- Note [Punning]
-  }
+  } deriving (Data, Typeable)
 
 -- Note [Punning]
 -- ~~~~~~~~~~~~~~
 -- If you write T { x, y = v+1 }, the HsRecFields will be
 --	HsRecField x x True ...
 --	HsRecField y (v+1) False ...
--- That is, for "punned" field x is immediately expanded to x=x
--- but with a punning flag so we can detect it later
+-- That is, for "punned" field x is expanded (in the renamer) 
+-- to x=x; but with a punning flag so we can detect it later
 -- (e.g. when pretty printing)
+--
+-- If the original field was qualified, we un-qualify it, thus
+--    T { A.x } means T { A.x = x }
 
 hsRecFields :: HsRecFields id arg -> [id]
 hsRecFields rbinds = map (unLoc . hsRecFieldId) (rec_flds rbinds)
 \end{code}
 
-\begin{code}
-data HsQuasiQuote id = HsQuasiQuote 
-		       id
-		       id
-		       SrcSpan
-		       FastString
-
-instance OutputableBndr id => Outputable (HsQuasiQuote id) where
-    ppr = ppr_qq
-
-ppr_qq :: OutputableBndr id => HsQuasiQuote id -> SDoc
-ppr_qq (HsQuasiQuote name quoter _ quote) =
-    char '$' <> brackets (ppr name) <>
-    ptext (sLit "[:") <> ppr quoter <> ptext (sLit "|") <>
-    ppr quote <> ptext (sLit "|]")
-\end{code}
-
-
 %************************************************************************
 %*									*
 %* 		Printing patterns
@@ -241,14 +240,30 @@ pprPatBndr var		  	-- Print with type info if -dppr-debug is on
     else
 	ppr var
 
+pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc
+pprParendLPat (L _ p) = pprParendPat p
+
+pprParendPat :: (OutputableBndr name) => Pat name -> SDoc
+pprParendPat p | patNeedsParens p = parens (pprPat p)
+               | otherwise        = pprPat p
+
+patNeedsParens :: Pat name -> Bool
+patNeedsParens (ConPatIn _ d)               = not (null (hsConPatArgs d))
+patNeedsParens (ConPatOut { pat_args = d }) = not (null (hsConPatArgs d))
+patNeedsParens (SigPatIn {})  = True
+patNeedsParens (SigPatOut {}) = True
+patNeedsParens (ViewPat {})   = True
+patNeedsParens (CoPat {})     = True
+patNeedsParens _              = False
+
 pprPat :: (OutputableBndr name) => Pat name -> SDoc
 pprPat (VarPat var)  	  = pprPatBndr var
-pprPat (VarPatOut var bs) = parens (pprPatBndr var <+> braces (ppr bs))
+pprPat (VarPatOut var bs) = pprPatBndr var <+> braces (ppr bs)
 pprPat (WildPat _)	  = char '_'
-pprPat (LazyPat pat)      = char '~' <> ppr pat
-pprPat (BangPat pat)      = char '!' <> ppr pat
-pprPat (AsPat name pat)   = parens (hcat [ppr name, char '@', ppr pat])
-pprPat (ViewPat expr pat _) = parens (hcat [pprLExpr expr, text " -> ", ppr pat])
+pprPat (LazyPat pat)      = char '~' <> pprParendLPat pat
+pprPat (BangPat pat)      = char '!' <> pprParendLPat pat
+pprPat (AsPat name pat)   = hcat [ppr name, char '@', pprParendLPat pat]
+pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
 pprPat (ParPat pat)	    = parens (ppr pat)
 pprPat (ListPat pats _)     = brackets (interpp'SP pats)
 pprPat (PArrPat pats _)     = pabrackets (interpp'SP pats)
@@ -264,26 +279,23 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
 		   	  pprLHsBinds binds, pprConArgs details]
     else pprUserCon con details
 
-pprPat (LitPat s)	      = ppr s
+pprPat (LitPat s)	    = ppr s
 pprPat (NPat l Nothing  _)  = ppr l
 pprPat (NPat l (Just _) _)  = char '-' <> ppr l
-pprPat (NPlusKPat n k _ _)    = hcat [ppr n, char '+', ppr k]
-pprPat (QuasiQuotePat (HsQuasiQuote name quoter _ quote)) 
-    = char '$' <> brackets (ppr name) <>
-      ptext (sLit "[:") <> ppr quoter <> ptext (sLit "|") <>
-      ppr quote <> ptext (sLit "|]")
-pprPat (TypePat ty)	      = ptext (sLit "{|") <> ppr ty <> ptext (sLit "|}")
-pprPat (CoPat co pat _)	      = parens (pprHsWrapper (ppr pat) co)
-pprPat (SigPatIn pat ty)      = ppr pat <+> dcolon <+> ppr ty
-pprPat (SigPatOut pat ty)     = ppr pat <+> dcolon <+> ppr ty
+pprPat (NPlusKPat n k _ _)  = hcat [ppr n, char '+', ppr k]
+pprPat (QuasiQuotePat qq)   = ppr qq
+pprPat (TypePat ty)	    = ptext (sLit "{|") <> ppr ty <> ptext (sLit "|}")
+pprPat (CoPat co pat _)	    = pprHsWrapper (ppr pat) co
+pprPat (SigPatIn pat ty)    = ppr pat <+> dcolon <+> ppr ty
+pprPat (SigPatOut pat ty)   = ppr pat <+> dcolon <+> ppr ty
 
 pprUserCon :: (Outputable con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc
 pprUserCon c (InfixCon p1 p2) = ppr p1 <+> ppr c <+> ppr p2
 pprUserCon c details          = ppr c <+> pprConArgs details
 
 pprConArgs ::  OutputableBndr id => HsConPatDetails id -> SDoc
-pprConArgs (PrefixCon pats) = interppSP pats
-pprConArgs (InfixCon p1 p2) = interppSP [p1,p2]
+pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
+pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
 pprConArgs (RecCon rpats)   = ppr rpats
 
 instance (OutputableBndr id, Outputable arg)
@@ -299,7 +311,7 @@ instance (OutputableBndr id, Outputable arg)
       => Outputable (HsRecField id arg) where
   ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg, 
 		    hsRecPun = pun })
-    = ppr f <+> (if pun then empty else equals <+> ppr arg)
+    = ppr f <+> (ppUnless pun $ equals <+> ppr arg)
 
 -- add parallel array brackets around a document
 --
@@ -369,34 +381,6 @@ patterns are treated specially, of course.
 
 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 \begin{code}
-hasViewPat :: LPat id -> Bool
-hasViewPat (L _ p) = go p where
-  go (WildPat _)             = False
-  go (VarPat _)              = False
-  go (VarPatOut _ _)         = False
-  go (LazyPat p)             = hasViewPat p
-  go (AsPat _ p)             = hasViewPat p
-  go (ParPat p)              = hasViewPat p
-  go (BangPat p)             = hasViewPat p
-  go (ListPat p _)           = any hasViewPat p
-  go (TuplePat p _ _)        = any hasViewPat p
-  go (PArrPat p _)           = any hasViewPat p
-  go (ConPatIn _ p)          = go' p
-  go (ConPatOut _ _ _ _ p _) = go' p
-  go (ViewPat _ _ _)         = True
-  go (QuasiQuotePat _)       = False
-  go (LitPat _)              = False
-  go (NPat _ _ _)            = False
-  go (NPlusKPat _ _ _ _)     = False
-  go (TypePat _)             = False
-  go (SigPatIn p _)          = hasViewPat p
-  go (SigPatOut p _)         = hasViewPat p
-  go (CoPat _ _ _)           = False
-  go' p = case p of
-    PrefixCon ps              -> any hasViewPat ps
-    RecCon (HsRecFields fs _) -> any (hasViewPat . hsRecFieldArg) fs
-    InfixCon p1 p2            -> hasViewPat p1 || hasViewPat p2
-
 isWildPat :: Pat id -> Bool
 isWildPat (WildPat _) = True
 isWildPat _           = False