Minor refactoring

[ghc-hetmet.git] / compiler / hsSyn / HsPat.lhs

diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index 0320706..af921de 100644 (file)
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -23,7 +23,7 @@ module HsPat (
 
        mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat, mkCoPatCoI,
 
-       isBangHsBind,   
+       isBangHsBind, hsPatNeedsParens,
        patsAreAllCons, isConPat, isSigPat, isWildPat,
        patsAreAllLits, isLitPat, isIrrefutableHsPat
     ) where
@@ -175,15 +175,23 @@ However HsRecFields is used only for patterns and expressions
 \begin{code}
 data HsRecFields id arg        -- A bunch of record fields
                                --      { x = 3, y = True }
-       -- Used for both expressiona and patterns
+       -- 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]
+
+-- 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,
@@ -196,9 +204,12 @@ data HsRecField id arg = HsRecField {
 -- 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)
@@ -210,6 +221,15 @@ data HsQuasiQuote id = HsQuasiQuote
                       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}
 
 
@@ -239,8 +259,8 @@ 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 (ParPat pat)      = parens (ppr pat)
+pprPat (ViewPat expr pat _) = parens (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)
 pprPat (TuplePat pats bx _) = tupleParens bx (interpp'SP pats)
@@ -290,7 +310,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
 --
@@ -408,12 +428,12 @@ isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
 isIrrefutableHsPat pat
   = go pat
   where
-    go (L _ pat)        = go1 pat
+    go (L _ pat) = go1 pat
 
-    go1 (WildPat _)         = True
-    go1 (VarPat _)          = True
-    go1 (VarPatOut _ _)     = True
-    go1 (LazyPat _)         = True
+    go1 (WildPat {})        = True
+    go1 (VarPat {})         = True
+    go1 (VarPatOut {})      = True
+    go1 (LazyPat {})        = True
     go1 (BangPat pat)       = go pat
     go1 (CoPat _ pat _)     = go1 pat
     go1 (ParPat pat)        = go pat
@@ -422,22 +442,50 @@ isIrrefutableHsPat pat
     go1 (SigPatIn pat _)    = go pat
     go1 (SigPatOut pat _)   = go pat
     go1 (TuplePat pats _ _) = all go pats
-    go1 (ListPat _ _)       = False
-    go1 (PArrPat _ _)       = False    -- ?
+    go1 (ListPat {})        = False
+    go1 (PArrPat {})        = False    -- ?
 
-    go1 (ConPatIn _ _) = False -- Conservative
+    go1 (ConPatIn {})       = False    -- Conservative
     go1 (ConPatOut{ pat_con = L _ con, pat_args = details }) 
        =  isProductTyCon (dataConTyCon con)
        && all go (hsConPatArgs details)
 
-    go1 (LitPat _)        = False
-    go1 (NPat _ _ _)      = False
-    go1 (NPlusKPat _ _ _ _) = False
+    go1 (LitPat {})    = False
+    go1 (NPat {})      = False
+    go1 (NPlusKPat {}) = False
 
     go1 (QuasiQuotePat {}) = urk pat   -- Gotten rid of by renamer, before
                                        -- isIrrefutablePat is called
     go1 (TypePat {})       = urk pat
 
     urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
+
+hsPatNeedsParens :: Pat a -> Bool
+hsPatNeedsParens (WildPat {})        = False
+hsPatNeedsParens (VarPat {})         = False
+hsPatNeedsParens (VarPatOut {})      = True
+hsPatNeedsParens (LazyPat {})        = False
+hsPatNeedsParens (BangPat {})        = False
+hsPatNeedsParens (CoPat {})          = True
+hsPatNeedsParens (ParPat {})         = False
+hsPatNeedsParens (AsPat {})          = False
+hsPatNeedsParens (ViewPat {})        = True
+hsPatNeedsParens (SigPatIn {})       = True
+hsPatNeedsParens (SigPatOut {})      = True
+hsPatNeedsParens (TuplePat {})       = False
+hsPatNeedsParens (ListPat {})        = False
+hsPatNeedsParens (PArrPat {})        = False   
+hsPatNeedsParens (ConPatIn _ ds)     = conPatNeedsParens ds
+hsPatNeedsParens (ConPatOut {})      = True
+hsPatNeedsParens (LitPat {})                = False
+hsPatNeedsParens (NPat {})          = False
+hsPatNeedsParens (NPlusKPat {})      = True
+hsPatNeedsParens (QuasiQuotePat {})  = True
+hsPatNeedsParens (TypePat {})        = False
+
+conPatNeedsParens :: HsConDetails a b -> Bool
+conPatNeedsParens (PrefixCon args) = not (null args)
+conPatNeedsParens (InfixCon {})    = False
+conPatNeedsParens (RecCon {})      = False
 \end{code}