remove empty dir
[ghc-hetmet.git] / ghc / compiler / hsSyn / HsPat.lhs
index c5fa2c7..953d228 100644 (file)
 
 \begin{code}
 module HsPat (
-       InPat(..),
-       OutPat(..),
-
-       irrefutablePat, irrefutablePats,
-       failureFreePat, isWildPat,
-       patsAreAllCons, isConPat,
-       patsAreAllLits, isLitPat,
-       collectPatBinders, collectPatsBinders,
-       collectSigTysFromPat, collectSigTysFromPats
+       Pat(..), InPat, OutPat, LPat,
+       
+       HsConDetails(..), hsConArgs,
+
+       mkPrefixConPat, mkCharLitPat, mkNilPat, 
+
+       isBangHsBind,   
+       patsAreAllCons, isConPat, isSigPat, isWildPat,
+       patsAreAllLits, isLitPat, isIrrefutableHsPat
     ) where
 
 #include "HsVersions.h"
 
 
--- friends:
-import HsLit           ( HsLit, HsOverLit )
-import HsExpr          ( HsExpr )
-import HsTypes         ( HsType )
-import BasicTypes      ( Fixity, Boxity, tupleParens )
+import {-# SOURCE #-} HsExpr           ( SyntaxExpr )
 
+-- friends:
+import HsBinds         ( DictBinds, HsBind(..), emptyLHsBinds, pprLHsBinds )
+import HsLit           ( HsLit(HsCharPrim), HsOverLit )
+import HsTypes         ( LHsType, PostTcType )
+import BasicTypes      ( Boxity, tupleParens )
 -- others:
-import Name            ( Name )
-import Var             ( Id, TyVar )
+import PprCore         ( {- instance OutputableBndr TyVar -} )
+import TysWiredIn      ( nilDataCon, charDataCon, charTy )
+import Var             ( TyVar )
 import DataCon         ( DataCon, dataConTyCon )
-import Name            ( isDataSymOcc, getOccName, NamedThing )
-import Maybes          ( maybeToBool )
+import TyCon           ( isProductTyCon )
 import Outputable      
-import TyCon           ( maybeTyConSingleCon )
 import Type            ( Type )
+import SrcLoc          ( Located(..), unLoc, noLoc )
 \end{code}
 
-Patterns come in distinct before- and after-typechecking flavo(u)rs.
+
 \begin{code}
-data InPat name
-  = WildPatIn                          -- wild card
-  | VarPatIn       name                -- variable
-  | LitPatIn       HsLit               -- literal
-  | LazyPatIn      (InPat name)        -- lazy pattern
-  | AsPatIn        name                -- as pattern
-                   (InPat name)
-  | SigPatIn       (InPat name)
-                   (HsType name)
-  | ConPatIn       name                -- constructed type
-                   [InPat name]
-  | ConOpPatIn     (InPat name)
-                   name
-                   Fixity              -- c.f. OpApp in HsExpr
-                   (InPat name)
-
-  | NPatIn         HsOverLit
-
-  | NPlusKPatIn            name                -- n+k pattern
-                   HsOverLit           -- It'll always be an HsIntegral
-                   Name                -- Name of '-' (see RnEnv.lookupSyntaxName)
-
-  -- We preserve prefix negation and parenthesis for the precedence parser.
-
-  | ParPatIn        (InPat name)       -- parenthesised pattern
-
-  | ListPatIn      [InPat name]        -- syntactic list
-                                       -- must have >= 1 elements
-  | TuplePatIn     [InPat name] Boxity -- tuple (boxed?)
-
-  | RecPatIn       name                -- record
-                   [(name, InPat name, Bool)]  -- True <=> source used punning
-
--- Generics
-  | TypePatIn       (HsType name)       -- Type pattern for generic definitions
+type InPat id  = LPat id       -- No 'Out' constructors
+type OutPat id = LPat id       -- No 'In' constructors
+
+type LPat id = Located (Pat id)
+
+data Pat id
+  =    ------------ Simple patterns ---------------
+    WildPat    PostTcType              -- Wild card
+  | VarPat     id                      -- Variable
+  | VarPatOut  id (DictBinds id)       -- Used only for overloaded Ids; the 
+                                       -- bindings give its overloaded instances
+  | LazyPat    (LPat id)               -- Lazy pattern
+  | AsPat      (Located id) (LPat id)  -- As pattern
+  | ParPat      (LPat id)              -- Parenthesised pattern
+  | BangPat    (LPat id)               -- Bang patterng
+
+       ------------ Lists, tuples, arrays ---------------
+  | ListPat    [LPat id]               -- Syntactic list
+               PostTcType              -- The type of the elements
+                   
+  | TuplePat   [LPat id]               -- Tuple
+               Boxity                  -- UnitPat is TuplePat []
+               PostTcType
+       -- You might think that the PostTcType was redundant, but it's essential
+       --      data T a where
+       --        T1 :: Int -> T Int
+       --      f :: (T a, a) -> Int
+       --      f (T1 x, z) = z
+       -- When desugaring, we must generate
+       --      f = /\a. \v::a.  case v of (t::T a, w::a) ->
+       --                       case t of (T1 (x::Int)) -> 
+       -- Note the (w::a), NOT (w::Int), because we have not yet
+       -- refined 'a' to Int.  So we must know that the second component
+       -- of the tuple is of type 'a' not Int.  See selectMatchVar
+
+  | PArrPat    [LPat id]               -- Syntactic parallel array
+               PostTcType              -- The type of the elements
+
+       ------------ Constructor patterns ---------------
+  | ConPatIn   (Located id)
+               (HsConDetails id (LPat id))
+
+  | ConPatOut  (Located DataCon)
+               [TyVar]                 -- Existentially bound type variables
+               [id]                    -- Ditto dictionaries
+               (DictBinds id)          -- Bindings involving those dictionaries
+               (HsConDetails id (LPat id))
+               Type                    -- The type of the pattern
+
+       ------------ Literal and n+k patterns ---------------
+  | LitPat         HsLit               -- Used for *non-overloaded* literal patterns:
+                                       -- Int#, Char#, Int, Char, String, etc.
+
+  | NPat           (HsOverLit id)              -- ALWAYS positive
+                   (Maybe (SyntaxExpr id))     -- Just (Name of 'negate') for negative
+                                               -- patterns, Nothing otherwise
+                   (SyntaxExpr id)             -- Equality checker, of type t->t->Bool
+                   PostTcType                  -- Type of the pattern
+
+  | NPlusKPat      (Located id)        -- n+k pattern
+                   (HsOverLit id)      -- It'll always be an HsIntegral
+                   (SyntaxExpr id)     -- (>=) function, of type t->t->Bool
+                   (SyntaxExpr id)     -- Name of '-' (see RnEnv.lookupSyntaxName)
+
+       ------------ Generics ---------------
+  | TypePat        (LHsType id)        -- Type pattern for generic definitions
                                         -- e.g  f{| a+b |} = ...
-                                        -- These show up only in class 
-                                       -- declarations,
+                                        -- These show up only in class declarations,
                                         -- and should be a top-level pattern
 
--- /Generics
-
-data OutPat id
-  = WildPat        Type        -- wild card
-  | VarPat         id          -- variable (type is in the Id)
-  | LazyPat        (OutPat id) -- lazy pattern
-  | AsPat          id          -- as pattern
-                   (OutPat id)
-
-  | ListPat                    -- Syntactic list
-                   Type        -- The type of the elements
-                   [OutPat id]
-
-  | TuplePat       [OutPat id] -- Tuple
-                   Boxity
-                               -- UnitPat is TuplePat []
-
-  | ConPat         DataCon
-                   Type        -- the type of the pattern
-                   [TyVar]     -- Existentially bound type variables
-                   [id]        -- Ditto dictionaries
-                   [OutPat id]
-
-  -- ConOpPats are only used on the input side
-
-  | RecPat         DataCon             -- Record constructor
-                   Type                -- The type of the pattern
-                   [TyVar]             -- Existentially bound type variables
-                   [id]                -- Ditto dictionaries
-                   [(Id, OutPat id, Bool)]     -- True <=> source used punning
-
-  | LitPat         -- Used for *non-overloaded* literal patterns:
-                   -- Int#, Char#, Int, Char, String, etc.
-                   HsLit
-                   Type                -- Type of pattern
-
-  | NPat           -- Used for literal patterns where there's an equality function to call
-                   HsLit                       -- The literal is retained so that
-                                               -- the desugarer can readily identify
-                                               -- equations with identical literal-patterns
-                                               -- Always HsInteger, HsRat or HsString.
-                   Type                        -- Type of pattern, t
-                   (HsExpr id (OutPat id))     -- Of type t -> Bool; detects match
-
-  | NPlusKPat      id
-                   Integer
-                   Type                        -- Type of pattern, t
-                   (HsExpr id (OutPat id))     -- Of type t -> Bool; detects match
-                   (HsExpr id (OutPat id))     -- Of type t -> t; subtracts k
+       ------------ Pattern type signatures ---------------
+  | SigPatIn       (LPat id)           -- Pattern with a type signature
+                   (LHsType id)
 
+  | SigPatOut      (LPat id)           -- Pattern with a type signature
+                   Type
+
+       ------------ Dictionary patterns (translation only) ---------------
   | 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
+HsConDetails is use both for patterns and for data type declarations
 
 \begin{code}
-instance (Outputable name) => Outputable (InPat name) where
-    ppr = pprInPat
-
-pprInPat :: (Outputable name) => InPat name -> SDoc
-
-pprInPat (WildPatIn)         = char '_'
-pprInPat (VarPatIn var)              = ppr var
-pprInPat (LitPatIn s)        = ppr s
-pprInPat (SigPatIn pat ty)    = ppr pat <+> dcolon <+> ppr ty
-pprInPat (LazyPatIn pat)      = char '~' <> ppr pat
-pprInPat (AsPatIn name pat)   = parens (hcat [ppr name, char '@', ppr pat])
-pprInPat (ParPatIn pat)              = parens (pprInPat pat)
-pprInPat (ListPatIn pats)     = brackets (interpp'SP pats)
-pprInPat (TuplePatIn pats bx) = tupleParens bx (interpp'SP pats)
-pprInPat (NPlusKPatIn n k _)  = parens (hcat [ppr n, char '+', ppr k])
-pprInPat (NPatIn l)          = ppr l
-
-pprInPat (ConPatIn c pats)
-  | null pats = ppr c
-  | otherwise = hsep [ppr c, interppSP pats] -- inner ParPats supply the necessary 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 (RecPatIn con rpats)
-  = hsep [ppr con, braces (hsep (punctuate comma (map (pp_rpat) rpats)))]
-  where
-    pp_rpat (v, _, True) = ppr v
-    pp_rpat (v, p, _)    = hsep [ppr v, char '=', ppr p]
-
-pprInPat (TypePatIn ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}")
+data HsConDetails id arg
+  = PrefixCon [arg]                    -- C p1 p2 p3
+  | RecCon    [(Located id, arg)]      -- C { x = p1, y = p2 }
+  | InfixCon  arg arg                  -- p1 `C` p2
+
+hsConArgs :: HsConDetails id arg -> [arg]
+hsConArgs (PrefixCon ps)   = ps
+hsConArgs (RecCon fs)      = map snd fs
+hsConArgs (InfixCon p1 p2) = [p1,p2]
 \end{code}
 
-\begin{code}
-instance (NamedThing id, Outputable id) => Outputable (OutPat id) where
-    ppr = pprOutPat
-\end{code}
+
+%************************************************************************
+%*                                                                     *
+%*             Printing patterns
+%*                                                                     *
+%************************************************************************
 
 \begin{code}
-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
-
--- Kludge to get infix constructors to come out right
--- when ppr'ing desugar warnings.
-pprOutPat (ConPat name ty tyvars dicts pats)
+instance (OutputableBndr name) => Outputable (Pat name) where
+    ppr = pprPat
+
+pprPatBndr :: OutputableBndr name => name -> SDoc
+pprPatBndr var                 -- Print with type info if -dppr-debug is on
   = getPprStyle $ \ sty ->
-    parens      $
-    case pats of
-      [p1,p2] 
-        | userStyle sty && isDataSymOcc (getOccName name) ->
-           hsep [ppr p1, ppr name, ppr p2]
-      _ -> hsep [ppr name, interppSP tyvars, interppSP dicts, interppSP pats]
-
-pprOutPat (ListPat ty pats)      = brackets (interpp'SP pats)
-pprOutPat (TuplePat pats boxity) = tupleParens boxity (interpp'SP pats)
-
-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 (v, _, True) = ppr v
-    pp_rpat (v, p, _)    = hsep [ppr v, char '=', ppr p]
+    if debugStyle sty then
+       parens (pprBndr LambdaBind var)         -- Could pass the site to pprPat
+                                               -- but is it worth it?
+    else
+       ppr var
+
+pprPat :: (OutputableBndr name) => Pat name -> SDoc
+pprPat (VarPat var)      = pprPatBndr var
+pprPat (VarPatOut var bs) = parens (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 (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)
+
+pprPat (ConPatIn con details) = pprUserCon con details
+pprPat (ConPatOut con tvs dicts binds 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
+       ppr con <+> sep [ hsep (map pprPatBndr tvs) <+> hsep (map pprPatBndr dicts),
+                         pprLHsBinds binds, pprConArgs details]
+    else pprUserCon 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 (TypePat ty)          = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}")
+pprPat (SigPatIn pat ty)      = ppr pat <+> dcolon <+> ppr ty
+pprPat (SigPatOut pat ty)     = ppr pat <+> dcolon <+> ppr ty
+pprPat (DictPat ds ms)       = parens (sep [ptext SLIT("{-dict-}"),
+                                            brackets (interpp'SP ds),
+                                            brackets (interpp'SP ms)])
+
+pprUserCon c (InfixCon p1 p2) = ppr p1 <+> ppr c <+> ppr p2
+pprUserCon c details          = ppr c <+> pprConArgs details
+
+pprConArgs (PrefixCon pats) = interppSP pats
+pprConArgs (InfixCon p1 p2) = interppSP [p1,p2]
+pprConArgs (RecCon rpats)   = braces (hsep (punctuate comma (map (pp_rpat) rpats)))
+                           where
+                             pp_rpat (v, p) = hsep [ppr v, char '=', ppr p]
+
+
+-- add parallel array brackets around a document
+--
+pabrackets   :: SDoc -> SDoc
+pabrackets p  = ptext SLIT("[:") <> p <> ptext SLIT(":]")
+\end{code}
+
 
-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 '+', integer k])
+%************************************************************************
+%*                                                                     *
+%*             Building patterns
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id
+-- Make a vanilla Prefix constructor pattern
+mkPrefixConPat dc pats ty = noLoc $ ConPatOut (noLoc dc) [] [] emptyLHsBinds (PrefixCon pats) ty
 
-pprOutPat (DictPat dicts methods)
- = parens (sep [ptext SLIT("{-dict-}"),
-                 brackets (interpp'SP dicts),
-                 brackets (interpp'SP methods)])
+mkNilPat :: Type -> OutPat id
+mkNilPat ty = mkPrefixConPat nilDataCon [] ty
 
+mkCharLitPat :: Char -> OutPat id
+mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] charTy
 \end{code}
 
+
 %************************************************************************
 %*                                                                     *
-%* predicates for checking things about pattern-lists in EquationInfo  *
+%* Predicates for checking things about pattern-lists in EquationInfo  *
 %*                                                                     *
 %************************************************************************
+
 \subsection[Pat-list-predicates]{Look for interesting things in patterns}
 
 Unlike in the Wadler chapter, where patterns are either ``variables''
@@ -251,109 +254,71 @@ patterns are treated specially, of course.
 
 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 \begin{code}
-irrefutablePats :: [OutPat id] -> Bool
-irrefutablePats pat_list = all irrefutablePat pat_list
-
-irrefutablePat (AsPat  _ pat)  = irrefutablePat pat
-irrefutablePat (WildPat        _)      = True
-irrefutablePat (VarPat _)      = True
-irrefutablePat (LazyPat        _)      = True
-irrefutablePat (DictPat ds ms) = (length ds + length ms) <= 1
-irrefutablePat other           = False
-
-failureFreePat :: OutPat id -> 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 (RecPat con _ _ _ fields)  = only_con con && and [ failureFreePat pat | (_,pat,_) <- fields ]
-failureFreePat (ListPat _ _)             = False
-failureFreePat (TuplePat pats _)         = all failureFreePat pats
-failureFreePat (DictPat _ _)             = True
-failureFreePat other_pat                 = False   -- Literals, NPat
-
-only_con con = maybeToBool (maybeTyConSingleCon (dataConTyCon con))
-\end{code}
-
-\begin{code}
 isWildPat (WildPat _) = True
 isWildPat other              = False
 
-patsAreAllCons :: [OutPat id] -> Bool
+patsAreAllCons :: [Pat id] -> Bool
 patsAreAllCons pat_list = all isConPat pat_list
 
-isConPat (AsPat _ pat)         = isConPat pat
-isConPat (ConPat _ _ _ _ _)    = True
-isConPat (ListPat _ _)         = True
-isConPat (TuplePat _ _)                = True
-isConPat (RecPat _ _ _ _ _)    = True
-isConPat (DictPat ds ms)       = (length ds + length ms) > 1
-isConPat other                 = False
-
-patsAreAllLits :: [OutPat id] -> Bool
-patsAreAllLits pat_list = all isLitPat pat_list
-
-isLitPat (AsPat _ pat)        = isLitPat pat
-isLitPat (LitPat _ _)         = True
-isLitPat (NPat   _ _ _)               = True
-isLitPat (NPlusKPat _ _ _ _ _) = True
-isLitPat other                = False
-\end{code}
+isConPat (AsPat _ pat)          = isConPat (unLoc pat)
+isConPat (ConPatIn _ _)                 = True
+isConPat (ConPatOut _ _ _ _ _ _) = True
+isConPat (ListPat _ _)          = True
+isConPat (PArrPat _ _)          = True
+isConPat (TuplePat _ _ _)       = True
+isConPat (DictPat ds ms)        = (length ds + length ms) > 1
+isConPat other                  = False
 
-This function @collectPatBinders@ works with the ``collectBinders''
-functions for @HsBinds@, etc.  The order in which the binders are
-collected is important; see @HsBinds.lhs@.
+isSigPat (SigPatIn _ _)  = True
+isSigPat (SigPatOut _ _) = True
+isSigPat other          = False
 
-\begin{code}
-collectPatBinders :: InPat a -> [a]
-collectPatBinders pat = collect pat []
-
-collectPatsBinders :: [InPat a] -> [a]
-collectPatsBinders pats = foldr collect [] pats
-
-collect WildPatIn               bndrs = bndrs
-collect (VarPatIn var)          bndrs = var : bndrs
-collect (LitPatIn _)            bndrs = bndrs
-collect (SigPatIn pat _)        bndrs = collect pat bndrs
-collect (LazyPatIn pat)         bndrs = collect pat bndrs
-collect (AsPatIn a pat)         bndrs = a : collect pat bndrs
-collect (NPlusKPatIn n _ _)      bndrs = n : bndrs
-collect (NPatIn _)              bndrs = bndrs
-collect (ConPatIn c pats)       bndrs = foldr collect bndrs pats
-collect (ConOpPatIn p1 c f p2)   bndrs = collect p1 (collect p2 bndrs)
-collect (ParPatIn  pat)         bndrs = collect pat bndrs
-collect (ListPatIn pats)        bndrs = foldr collect bndrs pats
-collect (TuplePatIn pats _)     bndrs = foldr collect bndrs pats
-collect (RecPatIn c fields)     bndrs = foldr (\ (f,pat,_) bndrs -> collect pat bndrs) bndrs fields
--- Generics
-collect (TypePatIn ty)           bndrs = bndrs
--- assume the type variables do not need to be bound
-\end{code}
+patsAreAllLits :: [Pat id] -> Bool
+patsAreAllLits pat_list = all isLitPat pat_list
 
-\begin{code}
-collectSigTysFromPats :: [InPat name] -> [HsType name]
-collectSigTysFromPats pats = foldr collect_pat [] pats
-
-collectSigTysFromPat :: InPat name -> [HsType name]
-collectSigTysFromPat pat = collect_pat pat []
-
-collect_pat (SigPatIn pat ty)     acc = collect_pat pat (ty:acc)
-collect_pat WildPatIn             acc = acc
-collect_pat (VarPatIn var)         acc = acc
-collect_pat (LitPatIn _)          acc = acc
-collect_pat (LazyPatIn pat)        acc = collect_pat pat acc
-collect_pat (AsPatIn a pat)        acc = collect_pat pat acc
-collect_pat (NPatIn _)            acc = acc
-collect_pat (NPlusKPatIn n _ _)    acc = acc
-collect_pat (ConPatIn c pats)      acc = foldr collect_pat acc pats
-collect_pat (ConOpPatIn p1 c f p2) acc = collect_pat p1 (collect_pat p2 acc)
-collect_pat (ParPatIn  pat)        acc = collect_pat pat acc
-collect_pat (ListPatIn pats)       acc = foldr collect_pat acc pats
-collect_pat (TuplePatIn pats _)    acc = foldr collect_pat acc pats
-collect_pat (RecPatIn c fields)    acc = foldr (\ (f,pat,_) acc -> collect_pat pat acc) acc fields
--- Generics
-collect_pat (TypePatIn ty)         acc = ty:acc
+isLitPat (AsPat _ pat)         = isLitPat (unLoc pat)
+isLitPat (LitPat _)            = True
+isLitPat (NPat _ _ _ _)                = True
+isLitPat (NPlusKPat _ _ _ _)    = True
+isLitPat other                 = False
+
+isBangHsBind :: HsBind id -> Bool
+-- In this module because HsPat is above HsBinds in the import graph
+isBangHsBind (PatBind { pat_lhs = L _ (BangPat p) }) = True
+isBangHsBind bind                                   = False
+
+isIrrefutableHsPat :: LPat id -> Bool
+-- This function returns False if it's in doubt; specifically
+-- on a ConPatIn it doesn't know the size of the constructor family
+-- But if it returns True, the pattern is definitely irrefutable
+isIrrefutableHsPat pat
+  = go pat
+  where
+    go (L _ pat)        = go1 pat
+
+    go1 (WildPat _)         = True
+    go1 (VarPat _)          = True
+    go1 (VarPatOut _ _)     = True
+    go1 (LazyPat pat)       = True
+    go1 (BangPat pat)       = go pat
+    go1 (ParPat pat)        = go pat
+    go1 (AsPat _ pat)       = go pat
+    go1 (SigPatIn pat _)    = go pat
+    go1 (SigPatOut pat _)   = go pat
+    go1 (TuplePat pats _ _) = all go pats
+    go1 (ListPat pats _)    = False
+    go1 (PArrPat pats _)    = False    -- ?
+
+    go1 (ConPatIn _ _) = False -- Conservative
+    go1 (ConPatOut (L _ con) _ _ _ details _) 
+       =  isProductTyCon (dataConTyCon con)
+       && all go (hsConArgs details)
+
+    go1 (LitPat _)        = False
+    go1 (NPat _ _ _ _)    = False
+    go1 (NPlusKPat _ _ _ _) = False
+
+    go1 (TypePat _)   = panic "isIrrefutableHsPat: type pattern"
+    go1 (DictPat _ _) = panic "isIrrefutableHsPat: type pattern"
 \end{code}