Merge MatchFixity and HsMatchContext
[ghc.git] / compiler / hsSyn / HsPat.hs
index 6cde908..ef667a1 100644 (file)
@@ -6,26 +6,35 @@
 -}
 
 {-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                       -- in module PlaceHolder
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module HsPat (
         Pat(..), InPat, OutPat, LPat,
 
-        HsConDetails(..),
         HsConPatDetails, hsConPatArgs,
-        HsRecFields(..), HsRecField(..), LHsRecField, hsRecFields,
+        HsRecFields(..), HsRecField'(..), LHsRecField',
+        HsRecField, LHsRecField,
+        HsRecUpdField, LHsRecUpdField,
+        hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,
+        hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr,
 
         mkPrefixConPat, mkCharLitPat, mkNilPat,
 
-        isStrictHsBind, looksLazyPatBind,
-        isStrictLPat, hsPatNeedsParens,
+        isUnliftedHsBind, looksLazyPatBind,
+        isUnliftedLPat, isBangedLPat, isBangedPatBind,
+        hsPatNeedsParens,
         isIrrefutableHsPat,
 
+        collectEvVarsPats,
+
         pprParendLPat, pprConArgs
     ) where
 
@@ -34,7 +43,7 @@ import {-# SOURCE #-} HsExpr            (SyntaxExpr, LHsExpr, HsSplice, pprLExpr
 -- friends:
 import HsBinds
 import HsLit
-import PlaceHolder ( PostTc,DataId )
+import PlaceHolder
 import HsTypes
 import TcEvidence
 import BasicTypes
@@ -42,16 +51,18 @@ import BasicTypes
 import PprCore          ( {- instance OutputableBndr TyVar -} )
 import TysWiredIn
 import Var
+import RdrName ( RdrName )
 import ConLike
 import DataCon
 import TyCon
 import Outputable
 import Type
 import SrcLoc
-import FastString
+import Bag -- collect ev vars from pats
+import DynFlags( gopt, GeneralFlag(..) )
+import Maybes
 -- libraries:
 import Data.Data hiding (TyCon,Fixity)
-import Data.Maybe
 
 type InPat id  = LPat id        -- No 'Out' constructors
 type OutPat id = LPat id        -- No 'In' constructors
@@ -67,7 +78,8 @@ data Pat id
         -- The sole reason for a type on a WildPat is to
         -- support hsPatType :: Pat Id -> Type
 
-  | VarPat      id                      -- Variable
+  | VarPat      (Located id) -- Variable
+                             -- See Note [Located RdrNames] in HsExpr
   | LazyPat     (LPat id)               -- Lazy pattern
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
 
@@ -137,18 +149,21 @@ data Pat id
 
   | ConPatOut {
         pat_con     :: Located ConLike,
-        pat_arg_tys :: [Type],          -- The univeral arg types, 1-1 with the universal
+        pat_arg_tys :: [Type],          -- The universal arg types, 1-1 with the universal
                                         -- tyvars of the constructor/pattern synonym
                                         --   Use (conLikeResTy pat_con pat_arg_tys) to get
                                         --   the type of the pattern
 
-        pat_tvs   :: [TyVar],           -- Existentially bound type variables (tyvars only)
+        pat_tvs   :: [TyVar],           -- Existentially bound type variables
         pat_dicts :: [EvVar],           -- Ditto *coercion variables* and *dictionaries*
                                         -- One reason for putting coercion variable here, I think,
                                         --      is to ensure their kinds are zonked
+
         pat_binds :: TcEvBinds,         -- Bindings involving those dictionaries
         pat_args  :: HsConPatDetails id,
         pat_wrap  :: HsWrapper          -- Extra wrapper to pass to the matcher
+                                        -- Only relevant for pattern-synonyms;
+                                        --   ignored for data cons
     }
 
         ------------ View patterns ---------------
@@ -178,22 +193,30 @@ data Pat id
                     (Maybe (SyntaxExpr id))     -- Just (Name of 'negate') for negative
                                                 -- patterns, Nothing otherwise
                     (SyntaxExpr id)             -- Equality checker, of type t->t->Bool
+                    (PostTc id Type)            -- Overall type of pattern. Might be
+                                                -- different than the literal's type
+                                                -- if (==) or negate changes the type
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | NPlusKPat       (Located id)        -- n+k pattern
                     (Located (HsOverLit id)) -- It'll always be an HsIntegral
-                    (SyntaxExpr id)     -- (>=) function, of type t->t->Bool
+                    (HsOverLit id)      -- See Note [NPlusK patterns] in TcPat
+                     -- NB: This could be (PostTc ...), but that induced a
+                     -- a new hs-boot file. Not worth it.
+
+                    (SyntaxExpr id)     -- (>=) function, of type t1->t2->Bool
                     (SyntaxExpr id)     -- Name of '-' (see RnEnv.lookupSyntaxName)
+                    (PostTc id Type)    -- Type of overall pattern
 
         ------------ Pattern type signatures ---------------
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | SigPatIn        (LPat id)                  -- Pattern with a type signature
-                    (HsWithBndrs id (LHsType id)) -- Signature can bind both
-                                                  -- kind and type vars
+  | SigPatIn        (LPat id)                 -- Pattern with a type signature
+                    (LHsSigWcType id)         -- Signature can bind both
+                                              -- kind and type vars
 
   | SigPatOut       (LPat id)           -- Pattern with a type signature
                     Type
@@ -205,17 +228,8 @@ 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 (Typeable)
 deriving instance (DataId id) => Data (Pat id)
 
--- HsConDetails is use for patterns/expressions *and* for data type declarations
-
-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))
 
 hsConPatArgs :: HsConPatDetails id -> [LPat id]
@@ -223,17 +237,17 @@ hsConPatArgs (PrefixCon ps)   = ps
 hsConPatArgs (RecCon fs)      = map (hsRecFieldArg . unLoc) (rec_flds fs)
 hsConPatArgs (InfixCon p1 p2) = [p1,p2]
 
-{-
-However HsRecFields is used only for patterns and expressions
-(not data type declarations)
--}
+-- HsRecFields is used only for patterns and expressions (not data type
+-- declarations)
 
 data HsRecFields id arg         -- A bunch of record fields
                                 --      { x = 3, y = True }
         -- Used for both expressions and patterns
   = HsRecFields { rec_flds   :: [LHsRecField id arg],
                   rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
-  deriving (Data, Typeable)
+  deriving (Functor, Foldable, Traversable)
+deriving instance (DataId id, Data arg) => Data (HsRecFields id arg)
+
 
 -- Note [DotDot fields]
 -- ~~~~~~~~~~~~~~~~~~~~
@@ -249,15 +263,22 @@ data HsRecFields id arg         -- A bunch of record fields
 --                     the first 'n' being the user-written ones
 --                     and the remainder being 'filled in' implicitly
 
-type LHsRecField id arg = Located (HsRecField id arg)
--- |  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
+type LHsRecField' id arg = Located (HsRecField' id arg)
+type LHsRecField  id arg = Located (HsRecField  id arg)
+type LHsRecUpdField id   = Located (HsRecUpdField id)
+
+type HsRecField    id arg = HsRecField' (FieldOcc id) arg
+type HsRecUpdField id     = HsRecField' (AmbiguousFieldOcc id) (LHsExpr id)
 
+-- |  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',
+--
 -- For details on above see note [Api annotations] in ApiAnnotation
-data HsRecField id arg = HsRecField {
-        hsRecFieldId  :: Located id,
-        hsRecFieldArg :: arg,           -- Filled in by renamer
-        hsRecPun      :: Bool           -- Note [Punning]
-  } deriving (Data, Typeable)
+data HsRecField' id arg = HsRecField {
+        hsRecFieldLbl :: Located id,
+        hsRecFieldArg :: arg,           -- ^ Filled in by renamer when punning
+        hsRecPun      :: Bool           -- ^ Note [Punning]
+  } deriving (Data, Functor, Foldable, Traversable)
+
 
 -- Note [Punning]
 -- ~~~~~~~~~~~~~~
@@ -271,8 +292,70 @@ data HsRecField id arg = HsRecField {
 -- 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 . unLoc) (rec_flds rbinds)
+
+-- Note [HsRecField and HsRecUpdField]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+-- A HsRecField (used for record construction and pattern matching)
+-- contains an unambiguous occurrence of a field (i.e. a FieldOcc).
+-- We can't just store the Name, because thanks to
+-- DuplicateRecordFields this may not correspond to the label the user
+-- wrote.
+--
+-- A HsRecUpdField (used for record update) contains a potentially
+-- ambiguous occurrence of a field (an AmbiguousFieldOcc).  The
+-- renamer will fill in the selector function if it can, but if the
+-- selector is ambiguous the renamer will defer to the typechecker.
+-- After the typechecker, a unique selector will have been determined.
+--
+-- The renamer produces an Unambiguous result if it can, rather than
+-- just doing the lookup in the typechecker, so that completely
+-- unambiguous updates can be represented by 'DsMeta.repUpdFields'.
+--
+-- For example, suppose we have:
+--
+--     data S = MkS { x :: Int }
+--     data T = MkT { x :: Int }
+--
+--     f z = (z { x = 3 }) :: S
+--
+-- The parsed HsRecUpdField corresponding to the record update will have:
+--
+--     hsRecFieldLbl = Unambiguous "x" PlaceHolder :: AmbiguousFieldOcc RdrName
+--
+-- After the renamer, this will become:
+--
+--     hsRecFieldLbl = Ambiguous   "x" PlaceHolder :: AmbiguousFieldOcc Name
+--
+-- (note that the Unambiguous constructor is not type-correct here).
+-- The typechecker will determine the particular selector:
+--
+--     hsRecFieldLbl = Unambiguous "x" $sel:x:MkS  :: AmbiguousFieldOcc Id
+--
+-- See also Note [Disambiguating record fields] in TcExpr.
+
+hsRecFields :: HsRecFields id arg -> [PostRn id id]
+hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)
+
+-- Probably won't typecheck at once, things have changed :/
+hsRecFieldsArgs :: HsRecFields id arg -> [arg]
+hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds)
+
+hsRecFieldSel :: HsRecField name arg -> Located (PostRn name name)
+hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl
+
+hsRecFieldId :: HsRecField Id arg -> Located Id
+hsRecFieldId = hsRecFieldSel
+
+hsRecUpdFieldRdr :: HsRecUpdField id -> Located RdrName
+hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl
+
+hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc Id) arg -> Located Id
+hsRecUpdFieldId = fmap selectorFieldOcc . hsRecUpdFieldOcc
+
+hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc Id) arg -> LFieldOcc Id
+hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
+
 
 {-
 ************************************************************************
@@ -282,7 +365,7 @@ hsRecFields rbinds = map (unLoc . hsRecFieldId . unLoc) (rec_flds rbinds)
 ************************************************************************
 -}
 
-instance (OutputableBndr name) => Outputable (Pat name) where
+instance (OutputableBndrId name) => Outputable (Pat name) where
     ppr = pprPat
 
 pprPatBndr :: OutputableBndr name => name -> SDoc
@@ -294,70 +377,85 @@ pprPatBndr var                  -- Print with type info if -dppr-debug is on
     else
         pprPrefixOcc var
 
-pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc
+pprParendLPat :: (OutputableBndrId name) => LPat name -> SDoc
 pprParendLPat (L _ p) = pprParendPat p
 
-pprParendPat :: (OutputableBndr name) => Pat name -> SDoc
-pprParendPat p | hsPatNeedsParens p = parens (pprPat p)
-               | otherwise          = pprPat p
-
-pprPat :: (OutputableBndr name) => Pat name -> SDoc
-pprPat (VarPat var)       = pprPatBndr var
-pprPat (WildPat _)        = char '_'
-pprPat (LazyPat pat)      = char '~' <> pprParendLPat pat
-pprPat (BangPat pat)      = char '!' <> pprParendLPat pat
-pprPat (AsPat name pat)   = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat]
-pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
-pprPat (ParPat pat)         = parens (ppr pat)
+pprParendPat :: (OutputableBndrId name) => Pat name -> SDoc
+pprParendPat p = sdocWithDynFlags $ \ dflags ->
+                 if need_parens dflags p
+                 then parens (pprPat p)
+                 else  pprPat p
+  where
+    need_parens dflags p
+      | CoPat {} <- p = gopt Opt_PrintTypecheckerElaboration dflags
+      | otherwise     = hsPatNeedsParens p
+      -- For a CoPat we need parens if we are going to show it, which
+      -- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper)
+      -- But otherwise the CoPat is discarded, so it
+      -- is the pattern inside that matters.  Sigh.
+
+pprPat :: (OutputableBndrId name) => Pat name -> SDoc
+pprPat (VarPat (L _ var))     = pprPatBndr var
+pprPat (WildPat _)            = char '_'
+pprPat (LazyPat pat)          = char '~' <> pprParendLPat pat
+pprPat (BangPat pat)          = char '!' <> pprParendLPat pat
+pprPat (AsPat name pat)       = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat]
+pprPat (ViewPat expr pat _)   = hcat [pprLExpr expr, text " -> ", ppr pat]
+pprPat (ParPat pat)           = parens (ppr pat)
+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 (SplicePat splice)     = pprSplice splice
+pprPat (CoPat co pat _)       = pprHsWrapper co (\parens -> if parens
+                                                            then pprParendPat pat
+                                                            else pprPat pat)
+pprPat (SigPatIn pat ty)      = ppr pat <+> dcolon <+> ppr ty
+pprPat (SigPatOut pat ty)     = ppr pat <+> dcolon <+> ppr ty
 pprPat (ListPat pats _ _)     = brackets (interpp'SP pats)
-pprPat (PArrPat pats _)     = paBrackets (interpp'SP pats)
-pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats)
-
+pprPat (PArrPat pats _)       = paBrackets (interpp'SP pats)
+pprPat (TuplePat pats bx _)   = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
 pprPat (ConPatIn con details) = pprUserCon (unLoc con) details
 pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
                     pat_binds = binds, pat_args = details })
-  = getPprStyle $ \ sty ->      -- Tiresome; in TcBinds.tcRhs we print out a
-    if debugStyle sty then      -- typechecked Pat in an error message,
-                                -- and we want to make sure it prints nicely
+  = sdocWithDynFlags $ \dflags ->
+       -- Tiresome; in TcBinds.tcRhs we print out a
+       -- typechecked Pat in an error message,
+       -- and we want to make sure it prints nicely
+    if gopt Opt_PrintTypecheckerElaboration dflags then
         ppr con
           <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
                          , ppr binds])
           <+> pprConArgs details
     else pprUserCon (unLoc con) details
 
-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 (SplicePat splice)   = pprSplice splice
-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 :: (OutputableBndr con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc
+pprUserCon :: (OutputableBndr con, OutputableBndrId id)
+           => con -> HsConPatDetails id -> SDoc
 pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2
 pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details
 
-pprConArgs ::  OutputableBndr id => HsConPatDetails id -> SDoc
+pprConArgs :: (OutputableBndrId id) => HsConPatDetails id -> SDoc
 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)
+instance (Outputable arg)
       => Outputable (HsRecFields id arg) where
   ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
         = braces (fsep (punctuate comma (map ppr flds)))
   ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
         = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
         where
-          dotdot = ptext (sLit "..") <+> ifPprDebug (ppr (drop n flds))
+          dotdot = text ".." <+> ifPprDebug (ppr (drop n flds))
 
-instance (OutputableBndr id, Outputable arg)
-      => Outputable (HsRecField id arg) where
-  ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg,
+instance (Outputable id, Outputable arg)
+      => Outputable (HsRecField' id arg) where
+  ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg,
                     hsRecPun = pun })
     = ppr f <+> (ppUnless pun $ equals <+> ppr arg)
 
+
 {-
 ************************************************************************
 *                                                                      *
@@ -412,17 +510,25 @@ patterns are treated specially, of course.
 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 -}
 
-isStrictLPat :: LPat id -> Bool
-isStrictLPat (L _ (ParPat p))             = isStrictLPat p
-isStrictLPat (L _ (BangPat {}))           = True
-isStrictLPat (L _ (TuplePat _ Unboxed _)) = True
-isStrictLPat _                            = False
+isUnliftedLPat :: LPat id -> Bool
+isUnliftedLPat (L _ (ParPat p))             = isUnliftedLPat p
+isUnliftedLPat (L _ (TuplePat _ Unboxed _)) = True
+isUnliftedLPat _                            = False
 
-isStrictHsBind :: HsBind id -> Bool
+isUnliftedHsBind :: HsBind id -> Bool
 -- A pattern binding with an outermost bang or unboxed tuple must be matched strictly
 -- Defined in this module because HsPat is above HsBinds in the import graph
-isStrictHsBind (PatBind { pat_lhs = p }) = isStrictLPat p
-isStrictHsBind _                         = False
+isUnliftedHsBind (PatBind { pat_lhs = p }) = isUnliftedLPat p
+isUnliftedHsBind _                         = False
+
+isBangedPatBind :: HsBind id -> Bool
+isBangedPatBind (PatBind {pat_lhs = pat}) = isBangedLPat pat
+isBangedPatBind _ = False
+
+isBangedLPat :: LPat id -> Bool
+isBangedLPat (L _ (ParPat p))   = isBangedLPat p
+isBangedLPat (L _ (BangPat {})) = True
+isBangedLPat _                  = False
 
 looksLazyPatBind :: HsBind id -> Bool
 -- Returns True of anything *except*
@@ -441,14 +547,18 @@ looksLazyLPat (L _ (VarPat {}))            = False
 looksLazyLPat (L _ (WildPat {}))           = False
 looksLazyLPat _                            = True
 
-isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
+isIrrefutableHsPat :: (OutputableBndrId id) => LPat id -> Bool
 -- (isIrrefutableHsPat p) is true if matching against p cannot fail,
 -- in the sense of falling through to the next pattern.
 --      (NB: this is not quite the same as the (silly) defn
 --      in 3.17.2 of the Haskell 98 report.)
 --
--- isIrrefutableHsPat returns False if it's in doubt; specifically
--- on a ConPatIn it doesn't know the size of the constructor family
+-- WARNING: isIrrefutableHsPat returns False if it's in doubt.
+-- Specifically on a ConPatIn, which is what it sees for a
+-- (LPat Name) in the renamer, it doesn't know the size of the
+-- constructor family, so it returns False.  Result: only
+-- tuple patterns are considered irrefuable at the renamer stage.
+--
 -- But if it returns True, the pattern is definitely irrefutable
 isIrrefutableHsPat pat
   = go pat
@@ -496,7 +606,7 @@ hsPatNeedsParens p@(ConPatOut {})    = conPatNeedsParens (pat_args p)
 hsPatNeedsParens (SigPatIn {})       = True
 hsPatNeedsParens (SigPatOut {})      = True
 hsPatNeedsParens (ViewPat {})        = True
-hsPatNeedsParens (CoPat {})          = True
+hsPatNeedsParens (CoPat _ p _)       = hsPatNeedsParens p
 hsPatNeedsParens (WildPat {})        = False
 hsPatNeedsParens (VarPat {})         = False
 hsPatNeedsParens (LazyPat {})        = False
@@ -513,3 +623,35 @@ conPatNeedsParens :: HsConDetails a b -> Bool
 conPatNeedsParens (PrefixCon args) = not (null args)
 conPatNeedsParens (InfixCon {})    = True
 conPatNeedsParens (RecCon {})      = True
+
+{-
+% Collect all EvVars from all constructor patterns
+-}
+
+-- May need to add more cases
+collectEvVarsPats :: [Pat id] -> Bag EvVar
+collectEvVarsPats = unionManyBags . map collectEvVarsPat
+
+collectEvVarsLPat :: LPat id -> Bag EvVar
+collectEvVarsLPat (L _ pat) = collectEvVarsPat pat
+
+collectEvVarsPat :: Pat id -> Bag EvVar
+collectEvVarsPat pat =
+  case pat of
+    LazyPat  p        -> collectEvVarsLPat p
+    AsPat _  p        -> collectEvVarsLPat p
+    ParPat   p        -> collectEvVarsLPat p
+    BangPat  p        -> collectEvVarsLPat p
+    ListPat  ps _ _   -> unionManyBags $ map collectEvVarsLPat ps
+    TuplePat ps _ _   -> unionManyBags $ map collectEvVarsLPat ps
+    PArrPat  ps _     -> unionManyBags $ map collectEvVarsLPat ps
+    ConPatOut {pat_dicts = dicts, pat_args  = args}
+                      -> unionBags (listToBag dicts)
+                                   $ unionManyBags
+                                   $ map collectEvVarsLPat
+                                   $ hsConPatArgs args
+    SigPatOut p _     -> collectEvVarsLPat p
+    CoPat _ p _       -> collectEvVarsPat  p
+    ConPatIn _  _     -> panic "foldMapPatBag: ConPatIn"
+    SigPatIn _ _      -> panic "foldMapPatBag: SigPatIn"
+    _other_pat        -> emptyBag