This BIG PATCH contains most of the work for the New Coercion Representation

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

diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index 25a350b..740bfa7 100644 (file)
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -22,8 +22,9 @@ module HsPat (
 
        mkPrefixConPat, mkCharLitPat, mkNilPat, 
 
-       isBangHsBind, isBangLPat, hsPatNeedsParens,
-       isIrrefutableHsPat,
+        isBangHsBind, isLiftedPatBind,
+        isBangLPat, hsPatNeedsParens,
+        isIrrefutableHsPat,
 
        pprParendLPat
     ) where
@@ -64,9 +65,7 @@ data Pat id
        -- support hsPatType :: Pat Id -> Type
 
   | VarPat     id                      -- Variable
-  | VarPatOut  id TcEvBinds            -- Used only for overloaded Ids; the 
-                                       -- bindings give its overloaded instances
-  | LazyPat    (LPat id)               -- Lazy pattern
+  | LazyPat     (LPat id)               -- Lazy pattern
   | AsPat      (Located id) (LPat id)  -- As pattern
   | ParPat      (LPat id)              -- Parenthesised pattern
   | BangPat    (LPat id)               -- Bang pattern
@@ -257,7 +256,6 @@ patNeedsParens _              = False
 
 pprPat :: (OutputableBndr name) => Pat name -> SDoc
 pprPat (VarPat var)      = pprPatBndr var
-pprPat (VarPatOut var bs) = pprPatBndr var <+> braces (ppr bs)
 pprPat (WildPat _)       = char '_'
 pprPat (LazyPat pat)      = char '~' <> pprParendLPat pat
 pprPat (BangPat pat)      = char '!' <> pprParendLPat pat
@@ -377,10 +375,29 @@ isBangLPat (L _ (ParPat p))   = isBangLPat p
 isBangLPat _                  = False
 
 isBangHsBind :: HsBind id -> Bool
--- In this module because HsPat is above HsBinds in the import graph
+-- A pattern binding with an outermost bang
+-- Defined in this module because HsPat is above HsBinds in the import graph
 isBangHsBind (PatBind { pat_lhs = p }) = isBangLPat p
 isBangHsBind _                         = False
 
+isLiftedPatBind :: HsBind id -> Bool
+-- A pattern binding with a compound pattern, not just a variable
+--    (I# x)       yes
+--    (# a, b #)   no, even if a::Int#
+--    x            no, even if x::Int#
+-- We want to warn about a missing bang-pattern on the yes's
+isLiftedPatBind (PatBind { pat_lhs = p }) = isLiftedLPat p
+isLiftedPatBind _                         = False
+
+isLiftedLPat :: LPat id -> Bool
+isLiftedLPat (L _ (ParPat p))   = isLiftedLPat p
+isLiftedLPat (L _ (BangPat p))  = isLiftedLPat p
+isLiftedLPat (L _ (AsPat _ p))  = isLiftedLPat p
+isLiftedLPat (L _ (TuplePat _ Unboxed _)) = False
+isLiftedLPat (L _ (VarPat {}))            = False
+isLiftedLPat (L _ (WildPat {}))           = False
+isLiftedLPat _                            = True
+
 isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
 -- (isIrrefutableHsPat p) is true if matching against p cannot fail,
 -- in the sense of falling through to the next pattern.
@@ -397,7 +414,6 @@ isIrrefutableHsPat pat
 
     go1 (WildPat {})        = True
     go1 (VarPat {})         = True
-    go1 (VarPatOut {})      = True
     go1 (LazyPat {})        = True
     go1 (BangPat pat)       = go pat
     go1 (CoPat _ pat _)     = go1 pat
@@ -430,7 +446,6 @@ isIrrefutableHsPat pat
 hsPatNeedsParens :: Pat a -> Bool
 hsPatNeedsParens (WildPat {})        = False
 hsPatNeedsParens (VarPat {})         = False
-hsPatNeedsParens (VarPatOut {})      = True
 hsPatNeedsParens (LazyPat {})        = False
 hsPatNeedsParens (BangPat {})        = False
 hsPatNeedsParens (CoPat {})          = True