Small refactor in desugar of pattern matching
[ghc.git] / compiler / deSugar / Match.hs
index af07e5b..1247961 100644 (file)
@@ -7,12 +7,16 @@ The @match@ function
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
 
-module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
+module Match ( match, matchEquations, matchWrapper, matchSimply
+             , matchSinglePat, matchSinglePatVar ) where
 
 #include "HsVersions.h"
 
-import {-#SOURCE#-} DsExpr (dsLExpr, dsExpr)
+import GhcPrelude
+
+import {-#SOURCE#-} DsExpr (dsLExpr, dsSyntaxExpr)
 
 import DynFlags
 import HsSyn
@@ -36,19 +40,21 @@ import MatchCon
 import MatchLit
 import Type
 import Coercion ( eqCoercion )
-import TcType ( toTcTypeBag )
 import TyCon( isNewTyCon )
 import TysWiredIn
-import ListSetOps
 import SrcLoc
 import Maybes
 import Util
 import Name
 import Outputable
-import BasicTypes ( isGenerated )
+import BasicTypes ( isGenerated, il_value, fl_value )
+import FastString
+import Unique
+import UniqDFM
 
 import Control.Monad( when, unless )
 import qualified Data.Map as Map
+import Data.List (groupBy)
 
 {-
 ************************************************************************
@@ -57,7 +63,8 @@ import qualified Data.Map as Map
 *                                                                      *
 ************************************************************************
 
-The function @match@ is basically the same as in the Wadler chapter,
+The function @match@ is basically the same as in the Wadler chapter
+from "The Implementation of Functional Programming Languages",
 except it is monadised, to carry around the name supply, info about
 annotations, etc.
 
@@ -90,7 +97,7 @@ is an embryonic @CoreExpr@ with a ``hole'' at the end for the
 final ``else expression''.
 \end{itemize}
 
-There is a type synonym, @EquationInfo@, defined in module @DsUtils@.
+There is a data type, @EquationInfo@, defined in module @DsMonad@.
 
 An experiment with re-ordering this information about equations (in
 particular, having the patterns available in column-major order)
@@ -119,43 +126,41 @@ patterns that is examined.  The steps carried out are roughly:
 \item
 Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
 bindings to the second component of the equation-info):
-\begin{itemize}
-\item
-Remove the `as' patterns from column~1.
-\item
-Make all constructor patterns in column~1 into @ConPats@, notably
-@ListPats@ and @TuplePats@.
-\item
-Handle any irrefutable (or ``twiddle'') @LazyPats@.
-\end{itemize}
 \item
 Now {\em unmix} the equations into {\em blocks} [w\/ local function
-@unmix_eqns@], in which the equations in a block all have variable
-patterns in column~1, or they all have constructor patterns in ...
+@match_groups@], in which the equations in a block all have the same
+ match group.
 (see ``the mixture rule'' in SLPJ).
 \item
-Call @matchEqnBlock@ on each block of equations; it will do the
-appropriate thing for each kind of column-1 pattern, usually ending up
-in a recursive call to @match@.
+Call the right match variant on each block of equations; it will do the
+appropriate thing for each kind of column-1 pattern.
 \end{enumerate}
 
 We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
 than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
 And gluing the ``success expressions'' together isn't quite so pretty.
 
-This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@
-(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and
-(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em
+This  @match@ uses @tidyEqnInfo@
+to get `as'- and `twiddle'-patterns out of the way (tidying), before
+applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em
 un}mixes the equations], producing a list of equation-info
-blocks, each block having as its first column of patterns either all
-constructors, or all variables (or similar beasts), etc.
+blocks, each block having as its first column patterns compatible with each other.
 
-@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the
-Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@
-corresponds roughly to @matchVarCon@.
+Note [Match Ids]
+~~~~~~~~~~~~~~~~
+Most of the matching functions take an Id or [Id] as argument.  This Id
+is the scrutinee(s) of the match. The desugared expression may
+sometimes use that Id in a local binding or as a case binder.  So it
+should not have an External name; Lint rejects non-top-level binders
+with External names (Trac #13043).
+
+See also Note [Localise pattern binders] in DsUtils
 -}
 
-match :: [Id]             -- Variables rep\'ing the exprs we\'re matching with
+type MatchId = Id   -- See Note [Match Ids]
+
+match :: [MatchId]        -- Variables rep\'ing the exprs we\'re matching with
+                          -- See Note [Match Ids]
       -> Type             -- Type of the case expression
       -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
       -> DsM MatchResult  -- Desugared result!
@@ -169,7 +174,8 @@ match [] ty eqns
                     | eqn <- eqns ]
 
 match vars@(v:_) ty eqns    -- Eqns *can* be empty
-  = do  { dflags <- getDynFlags
+  = ASSERT2( all (isInternalName . idName) vars, ppr vars )
+    do  { dflags <- getDynFlags
                 -- Tidy the first pattern, generating
                 -- auxiliary bindings if necessary
         ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
@@ -196,11 +202,12 @@ match vars@(v:_) ty eqns    -- Eqns *can* be empty
     match_group [] = panic "match_group"
     match_group eqns@((group,_) : _)
         = case group of
-            PgCon {}  -> matchConFamily  vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns])
+            PgCon {}  -> matchConFamily  vars ty (subGroupUniq [(c,e) | (PgCon c, e) <- eqns])
             PgSyn {}  -> matchPatSyn     vars ty (dropGroup eqns)
-            PgLit {}  -> matchLiterals   vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns])
+            PgLit {}  -> matchLiterals   vars ty (subGroupOrd [(l,e) | (PgLit l, e) <- eqns])
             PgAny     -> matchVariables  vars ty (dropGroup eqns)
             PgN {}    -> matchNPats      vars ty (dropGroup eqns)
+            PgOverS {}-> matchNPats      vars ty (dropGroup eqns)
             PgNpK {}  -> matchNPlusKPats vars ty (dropGroup eqns)
             PgBang    -> matchBangs      vars ty (dropGroup eqns)
             PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)
@@ -217,12 +224,12 @@ match vars@(v:_) ty eqns    -- Eqns *can* be empty
                                            case p of PgView e _ -> e:acc
                                                      _ -> acc) [] group) eqns
             maybeWarn [] = return ()
-            maybeWarn l = warnDs (vcat l)
+            maybeWarn l = warnDs NoReason (vcat l)
         in
           maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
                        (filter (not . null) gs))
 
-matchEmpty :: Id -> Type -> DsM [MatchResult]
+matchEmpty :: MatchId -> Type -> DsM [MatchResult]
 -- See Note [Empty case expressions]
 matchEmpty var res_ty
   = return [MatchResult CanFail mk_seq]
@@ -230,38 +237,39 @@ matchEmpty var res_ty
     mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty
                                       [(DEFAULT, [], fail)]
 
-matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+matchVariables :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Real true variables, just like in matchVar, SLPJ p 94
 -- No binding to do: they'll all be wildcards by now (done in tidy)
 matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
 matchVariables [] _ _ = panic "matchVariables"
 
-matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+matchBangs :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
 matchBangs (var:vars) ty eqns
   = do  { match_result <- match (var:vars) ty $
                           map (decomposeFirstPat getBangPat) eqns
         ; return (mkEvalMatchResult var ty match_result) }
 matchBangs [] _ _ = panic "matchBangs"
 
-matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Apply the coercion to the match variable and then match that
 matchCoercion (var:vars) ty (eqns@(eqn1:_))
-  = do  { let CoPat co pat _ = firstPat eqn1
+  = do  { let CoPat co pat _ = firstPat eqn1
         ; let pat_ty' = hsPatType pat
         ; var' <- newUniqueId var pat_ty'
         ; match_result <- match (var':vars) ty $
                           map (decomposeFirstPat getCoPat) eqns
-        ; rhs' <- dsHsWrapper co (Var var)
-        ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }
+        ; core_wrap <- dsHsWrapper co
+        ; let bind = NonRec var' (core_wrap (Var var))
+        ; return (mkCoLetMatchResult bind match_result) }
 matchCoercion _ _ _ = panic "matchCoercion"
 
-matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+matchView :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Apply the view function to the match variable and then match that
 matchView (var:vars) ty (eqns@(eqn1:_))
   = do  { -- we could pass in the expr from the PgView,
          -- but this needs to extract the pat anyway
          -- to figure out the type of the fresh variable
-         let ViewPat viewExpr (L _ pat) _ = firstPat eqn1
+         let ViewPat _ viewExpr (L _ pat) = firstPat eqn1
          -- do the rest of the compilation
         ; let pat_ty' = hsPatType pat
         ; var' <- newUniqueId var pat_ty'
@@ -269,35 +277,38 @@ matchView (var:vars) ty (eqns@(eqn1:_))
                           map (decomposeFirstPat getViewPat) eqns
          -- compile the view expressions
         ; viewExpr' <- dsLExpr viewExpr
-        ; return (mkViewMatchResult var' viewExpr' var match_result) }
+        ; return (mkViewMatchResult var'
+                    (mkCoreAppDs (text "matchView") viewExpr' (Var var))
+                    match_result) }
 matchView _ _ _ = panic "matchView"
 
-matchOverloadedList :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
 matchOverloadedList (var:vars) ty (eqns@(eqn1:_))
 -- Since overloaded list patterns are treated as view patterns,
 -- the code is roughly the same as for matchView
-  = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1
+  = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1
        ; var' <- newUniqueId var (mkListTy elt_ty)  -- we construct the overall type by hand
        ; match_result <- match (var':vars) ty $
                             map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
-       ; e' <- dsExpr e
-       ; return (mkViewMatchResult var' e' var match_result) }
+       ; e' <- dsSyntaxExpr e [Var var]
+       ; return (mkViewMatchResult var' e' match_result) }
 matchOverloadedList _ _ _ = panic "matchOverloadedList"
 
 -- decompose the first pattern and leave the rest alone
-decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo
+decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
 decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
         = eqn { eqn_pats = extractpat pat : pats}
 decomposeFirstPat _ _ = panic "decomposeFirstPat"
 
-getCoPat, getBangPat, getViewPat, getOLPat :: Pat Id -> Pat Id
-getCoPat (CoPat _ pat _)     = pat
+getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc
+getCoPat (CoPat _ _ pat _)   = pat
 getCoPat _                   = panic "getCoPat"
-getBangPat (BangPat pat  )   = unLoc pat
+getBangPat (BangPat _ pat  ) = unLoc pat
 getBangPat _                 = panic "getBangPat"
-getViewPat (ViewPat _ pat _) = unLoc pat
+getViewPat (ViewPat _ _ pat) = unLoc pat
 getViewPat _                 = panic "getViewPat"
-getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing
+getOLPat (ListPat (ListPatTc ty (Just _)) pats)
+        = ListPat (ListPatTc ty Nothing)  pats
 getOLPat _                   = panic "getOLPat"
 
 {-
@@ -326,39 +337,40 @@ See also Note [Case elimination: lifted case] in Simplify.
 ************************************************************************
 
 Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
-which will be scrutinised.  This means:
-\begin{itemize}
-\item
-Replace variable patterns @x@ (@x /= v@) with the pattern @_@,
-together with the binding @x = v@.
-\item
-Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
-\item
-Removing lazy (irrefutable) patterns (you don't want to know...).
-\item
-Converting explicit tuple-, list-, and parallel-array-pats into ordinary
-@ConPats@.
-\item
-Convert the literal pat "" to [].
-\end{itemize}
+which will be scrutinised.
 
-The result of this tidying is that the column of patterns will include
-{\em only}:
-\begin{description}
-\item[@WildPats@:]
-The @VarPat@ information isn't needed any more after this.
+This makes desugaring the pattern match simpler by transforming some of
+the patterns to simpler forms. (Tuples to Constructor Patterns)
 
-\item[@ConPats@:]
-@ListPats@, @TuplePats@, etc., are all converted into @ConPats@.
+Among other things in the resulting Pattern:
+* Variables and irrefutable(lazy) patterns are replaced by Wildcards
+* As patterns are replaced by the patterns they wrap.
+
+The bindings created by the above patterns are put into the returned wrapper
+instead.
+
+This means a definition of the form:
+  f x = rhs
+when called with v get's desugared to the equivalent of:
+  let x = v
+  in
+  f _ = rhs
+
+The same principle holds for as patterns (@) and
+irrefutable/lazy patterns (~).
+In the case of irrefutable patterns the irrefutable pattern is pushed into
+the binding.
+
+Pattern Constructors which only represent syntactic sugar are converted into
+their desugared representation.
+This usually means converting them to Constructor patterns but for some
+depends on enabled extensions. (Eg OverloadedLists)
+
+GHC also tries to convert overloaded Literals into regular ones.
+
+The result of this tidying is that the column of patterns will include
+only these which can be assigned a PatternGroup (see patGroup).
 
-\item[@LitPats@ and @NPats@:]
-@LitPats@/@NPats@ of ``known friendly types'' (Int, Char,
-Float,  Double, at least) are converted to unboxed form; e.g.,
-\tr{(NPat (HsInt i) _ _)} is converted to:
-\begin{verbatim}
-(ConPat I# _ _ [LitPat (HsIntPrim i)])
-\end{verbatim}
-\end{description}
 -}
 
 tidyEqnInfo :: Id -> EquationInfo
@@ -369,12 +381,7 @@ tidyEqnInfo :: Id -> EquationInfo
         -- one pattern and fiddling the list of bindings.
         --
         -- POST CONDITION: head pattern in the EqnInfo is
-        --      WildPat
-        --      ConPat
-        --      NPat
-        --      LitPat
-        --      NPlusKPat
-        -- but no other
+        --      one of these for which patGroup is defined.
 
 tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
   = panic "tidyEqnInfo"
@@ -383,35 +390,30 @@ tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats })
   = do { (wrap, pat') <- tidy1 v pat
        ; return (wrap, eqn { eqn_pats = do pat' : pats }) }
 
-tidy1 :: Id               -- The Id being scrutinised
-      -> Pat Id           -- The pattern against which it is to be matched
-      -> DsM (DsWrapper,  -- Extra bindings to do before the match
-              Pat Id)     -- Equivalent pattern
+tidy1 :: Id                  -- The Id being scrutinised
+      -> Pat GhcTc           -- The pattern against which it is to be matched
+      -> DsM (DsWrapper,     -- Extra bindings to do before the match
+              Pat GhcTc)     -- Equivalent pattern
 
 -------------------------------------------------------
 --      (pat', mr') = tidy1 v pat mr
 -- tidies the *outer level only* of pat, giving pat'
 -- It eliminates many pattern forms (as-patterns, variable patterns,
--- list patterns, etc) yielding one of:
---      WildPat
---      ConPatOut
---      LitPat
---      NPat
---      NPlusKPat
-
-tidy1 v (ParPat pat)      = tidy1 v (unLoc pat)
-tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat)
-tidy1 _ (WildPat ty)      = return (idDsWrapper, WildPat ty)
-tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p
+-- list patterns, etc) and returns any created bindings in the wrapper.
+
+tidy1 v (ParPat _ pat)      = tidy1 v (unLoc pat)
+tidy1 v (SigPat _ pat)      = tidy1 v (unLoc pat)
+tidy1 _ (WildPat ty)        = return (idDsWrapper, WildPat ty)
+tidy1 v (BangPat _ (L l p)) = tidy_bang_pat v l p
 
         -- case v of { x -> mr[] }
         -- = case v of { _ -> let x=v in mr[] }
-tidy1 v (VarPat (L _ var))
+tidy1 v (VarPat (L _ var))
   = return (wrapBind var v, WildPat (idType var))
 
         -- case v of { x@p -> mr[] }
         -- = case v of { p -> let x=v in mr[] }
-tidy1 v (AsPat (L _ var) pat)
+tidy1 v (AsPat (L _ var) pat)
   = do  { (wrap, pat') <- tidy1 v (unLoc pat)
         ; return (wrapBind var v . wrap, pat') }
 
@@ -426,39 +428,47 @@ tidy1 v (AsPat (L _ var) pat)
     The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
 -}
 
-tidy1 v (LazyPat pat)
-  = do  { (_,sel_prs) <- mkSelectorBinds False [] pat (Var v)
+tidy1 v (LazyPat _ pat)
+    -- This is a convenient place to check for unlifted types under a lazy pattern.
+    -- Doing this check during type-checking is unsatisfactory because we may
+    -- not fully know the zonked types yet. We sure do here.
+  = do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat)
+        ; unless (null unlifted_bndrs) $
+          putSrcSpanDs (getLoc pat) $
+          errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$
+                       text "Unlifted variables:")
+                    2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id))
+                                 unlifted_bndrs)))
+
+        ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)
         ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
         ; return (mkCoreLets sel_binds, WildPat (idType v)) }
 
-tidy1 _ (ListPat pats ty Nothing)
+tidy1 _ (ListPat (ListPatTc ty Nothing) pats )
   = return (idDsWrapper, unLoc list_ConPat)
   where
     list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
                         (mkNilPat ty)
                         pats
 
--- Introduce fake parallel array constructors to be able to handle parallel
--- arrays with the existing machinery for constructor pattern
-tidy1 _ (PArrPat pats ty)
-  = return (idDsWrapper, unLoc parrConPat)
-  where
-    arity      = length pats
-    parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty]
-
-tidy1 _ (TuplePat pats boxity tys)
+tidy1 _ (TuplePat tys pats boxity)
   = return (idDsWrapper, unLoc tuple_ConPat)
   where
     arity = length pats
     tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys
 
+tidy1 _ (SumPat tys pat alt arity)
+  = return (idDsWrapper, unLoc sum_ConPat)
+  where
+    sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys
+
 -- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ (LitPat lit)
+tidy1 _ (LitPat lit)
   = return (idDsWrapper, tidyLitPat lit)
 
 -- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ (NPat (L _ lit) mb_neg eq)
-  = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq)
+tidy1 _ (NPat ty (L _ lit) mb_neg eq)
+  = return (idDsWrapper, tidyNPat lit mb_neg eq ty)
 
 -- Everything else goes through unchanged...
 
@@ -466,29 +476,35 @@ tidy1 _ non_interesting_pat
   = return (idDsWrapper, non_interesting_pat)
 
 --------------------
-tidy_bang_pat :: Id -> SrcSpan -> Pat Id -> DsM (DsWrapper, Pat Id)
+tidy_bang_pat :: Id -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
 
 -- Discard par/sig under a bang
-tidy_bang_pat v _ (ParPat (L l p))      = tidy_bang_pat v l p
-tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p
+tidy_bang_pat v _ (ParPat _ (L l p)) = tidy_bang_pat v l p
+tidy_bang_pat v _ (SigPat _ (L l p)) = tidy_bang_pat v l p
 
 -- Push the bang-pattern inwards, in the hope that
 -- it may disappear next time
-tidy_bang_pat v l (AsPat v' p)  = tidy1 v (AsPat v' (L l (BangPat p)))
-tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t)
+tidy_bang_pat v l (AsPat x v' p) = tidy1 v (AsPat x v' (L l (BangPat noExt p)))
+tidy_bang_pat v l (CoPat x w p t)
+  = tidy1 v (CoPat x w (BangPat noExt (L l p)) t)
 
 -- Discard bang around strict pattern
 tidy_bang_pat v _ p@(LitPat {})    = tidy1 v p
 tidy_bang_pat v _ p@(ListPat {})   = tidy1 v p
 tidy_bang_pat v _ p@(TuplePat {})  = tidy1 v p
-tidy_bang_pat v _ p@(PArrPat {})   = tidy1 v p
+tidy_bang_pat v _ p@(SumPat {})    = tidy1 v p
 
 -- Data/newtype constructors
-tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc), pat_args = args })
-  | isNewTyCon (dataConTyCon dc)   -- Newtypes: push bang inwards (Trac #9844)
-  = tidy1 v (p { pat_args = push_bang_into_newtype_arg l args })
-  | otherwise                      -- Data types: discard the bang
-  = tidy1 v p
+tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc)
+                               , pat_args = args
+                               , pat_arg_tys = arg_tys })
+  -- Newtypes: push bang inwards (Trac #9844)
+  =
+    if isNewTyCon (dataConTyCon dc)
+      then tidy1 v (p { pat_args = push_bang_into_newtype_arg l ty args })
+      else tidy1 v p  -- Data types: discard the bang
+    where
+      (ty:_) = dataConInstArgTys dc arg_tys
 
 -------------------
 -- Default case, leave the bang there:
@@ -505,21 +521,28 @@ tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc), pat_args = args
 --
 -- NB: SigPatIn, ConPatIn should not happen
 
-tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))
+tidy_bang_pat _ l p = return (idDsWrapper, BangPat noExt (L l p))
 
 -------------------
-push_bang_into_newtype_arg :: SrcSpan -> HsConPatDetails Id -> HsConPatDetails Id
+push_bang_into_newtype_arg :: SrcSpan
+                           -> Type -- The type of the argument we are pushing
+                                   -- onto
+                           -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
 -- See Note [Bang patterns and newtypes]
 -- We are transforming   !(N p)   into   (N !p)
-push_bang_into_newtype_arg l (PrefixCon (arg:args))
+push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
   = ASSERT( null args)
-    PrefixCon [L l (BangPat arg)]
-push_bang_into_newtype_arg l (RecCon rf)
+    PrefixCon [L l (BangPat noExt arg)]
+push_bang_into_newtype_arg l _ty (RecCon rf)
   | HsRecFields { rec_flds = L lf fld : flds } <- rf
   , HsRecField { hsRecFieldArg = arg } <- fld
   = ASSERT( null flds)
-    RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] })
-push_bang_into_newtype_arg _ cd
+    RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg
+                                           = L l (BangPat noExt arg) })] })
+push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
+  | HsRecFields { rec_flds = [] } <- rf
+  = PrefixCon [L l (BangPat noExt (noLoc (WildPat ty)))]
+push_bang_into_newtype_arg _ _ cd
   = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
 
 {-
@@ -534,6 +557,9 @@ So what we do is to push the bang inwards, in the hope that it will
 get discarded there.  So we transform
    !(N pat)   into    (N !pat)
 
+But what if there is nothing to push the bang onto? In at least one instance
+a user has written !(N {}) which we translate into (N !_). See #13215
+
 
 \noindent
 {\bf Previous @matchTwiddled@ stuff:}
@@ -612,7 +638,7 @@ is collected here, in @matchWrapper@.  This function takes as
 arguments:
 \begin{itemize}
 \item
-Typchecked @Matches@ (of a function definition, or a case or lambda
+Typechecked @Matches@ (of a function definition, or a case or lambda
 expression)---the main input;
 \item
 An error message to be inserted into any (runtime) pattern-matching
@@ -645,10 +671,10 @@ Call @match@ with all of this information!
 \end{enumerate}
 -}
 
-matchWrapper :: HsMatchContext Name         -- For shadowing warning messages
-             -> Maybe (LHsExpr Id)          -- The scrutinee, if we check a case expr
-             -> MatchGroup Id (LHsExpr Id)  -- Matches being desugared
-             -> DsM ([Id], CoreExpr)        -- Results
+matchWrapper :: HsMatchContext Name    -- For shadowing warning messages
+             -> Maybe (LHsExpr GhcTc)  -- The scrutinee, if we check a case expr
+             -> MatchGroup GhcTc (LHsExpr GhcTc)   -- Matches being desugared
+             -> DsM ([Id], CoreExpr)   -- Results
 
 {-
  There is one small problem with the Lambda Patterns, when somebody
@@ -675,60 +701,46 @@ JJQC 30-Nov-1997
 -}
 
 matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
-                             , mg_arg_tys = arg_tys
-                             , mg_res_ty = rhs_ty
+                             , mg_ext = MatchGroupTc arg_tys rhs_ty
                              , mg_origin = origin })
   = do  { dflags <- getDynFlags
         ; locn   <- getSrcSpanDs
 
         ; new_vars    <- case matches of
-                           []    -> mapM newSysLocalDs arg_tys
+                           []    -> mapM newSysLocalDsNoLP arg_tys
                            (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))
 
         ; eqns_info   <- mapM (mk_eqn_info new_vars) matches
 
         -- pattern match check warnings
-        ; unless (isGenerated origin) $ do
-
-            when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $ do
-
-              -- Count the number of guards that can fail
-              guards <- computeNoGuards matches
-
-              let simplify = not (gopt Opt_FullGuardReasoning dflags)
-                              && (guards > maximum_failing_guards)
-
+        ; unless (isGenerated origin) $
+          when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $
+          addTmCsDs (genCaseTmCs1 mb_scr new_vars) $
               -- See Note [Type and Term Equality Propagation]
-              addTmCsDs (genCaseTmCs1 mb_scr new_vars) $
-                dsPmWarn dflags (DsMatchContext ctxt locn) $
-                  checkMatches simplify new_vars matches
-
-              when (not (gopt Opt_FullGuardReasoning dflags)
-                      && wopt Opt_WarnTooManyGuards dflags
-                      && guards > maximum_failing_guards)
-                   (warnManyGuards (DsMatchContext ctxt locn))
+          checkMatches dflags (DsMatchContext ctxt locn) new_vars matches
 
         ; result_expr <- handleWarnings $
                          matchEquations ctxt new_vars eqns_info rhs_ty
         ; return (new_vars, result_expr) }
   where
-    mk_eqn_info vars (L _ (Match _ pats _ grhss))
+    mk_eqn_info vars (L _ (Match { m_pats = pats, m_grhss = grhss }))
       = do { dflags <- getDynFlags
-           ; let upats = map (getMaybeStrictPat dflags) pats
-                 dicts = toTcTypeBag (collectEvVarsPats upats) -- Only TcTyVars
+           ; let upats = map (unLoc . decideBangHood dflags) pats
+                 dicts = collectEvVarsPats upats
            ; tm_cs <- genCaseTmCs2 mb_scr upats vars
-           ; match_result <- addDictsDs dicts $  -- See Note [Type and Term Equality Propagation]
-                               addTmCsDs tm_cs $ -- See Note [Type and Term Equality Propagation]
-                                 dsGRHSs ctxt upats grhss rhs_ty
-           ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }
+           ; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation]
+                             addTmCsDs tm_cs  $ -- See Note [Type and Term Equality Propagation]
+                             dsGRHSs ctxt grhss rhs_ty
+           ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) }
+    mk_eqn_info _ (L _ (XMatch _)) = panic "matchWrapper"
 
     handleWarnings = if isGenerated origin
                      then discardWarningsDs
                      else id
-
+matchWrapper _ _ (XMatchGroup _) = panic "matchWrapper"
 
 matchEquations  :: HsMatchContext Name
-                -> [Id] -> [EquationInfo] -> Type
+                -> [MatchId] -> [EquationInfo] -> Type
                 -> DsM CoreExpr
 matchEquations ctxt vars eqns_info rhs_ty
   = do  { let error_doc = matchContextErrString ctxt
@@ -752,7 +764,7 @@ pattern. It returns an expression.
 
 matchSimply :: CoreExpr                 -- Scrutinee
             -> HsMatchContext Name      -- Match kind
-            -> LPat Id                  -- Pattern it should match
+            -> LPat GhcTc               -- Pattern it should match
             -> CoreExpr                 -- Return this if it matches
             -> CoreExpr                 -- Return this if it doesn't
             -> DsM CoreExpr
@@ -765,30 +777,38 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do
     match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
     extractMatchResult match_result' fail_expr
 
-matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
+matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat GhcTc
                -> Type -> MatchResult -> DsM MatchResult
--- Do not warn about incomplete patterns
+-- matchSinglePat ensures that the scrutinee is a variable
+-- and then calls matchSinglePatVar
+--
+-- matchSinglePat does not warn about incomplete patterns
 -- Used for things like [ e | pat <- stuff ], where
 -- incomplete patterns are just fine
-matchSinglePat (Var var) ctx pat ty match_result
-  = do { dflags <- getDynFlags
-       ; locn   <- getSrcSpanDs
-       ; let pat' = getMaybeStrictPat dflags pat
-       -- pattern match check warnings
-       ; dsPmWarn dflags (DsMatchContext ctx locn) (checkSingle var pat')
 
-       ; match [var] ty
-               [EqnInfo { eqn_pats = [pat'], eqn_rhs  = match_result }] }
+matchSinglePat (Var var) ctx pat ty match_result
+  | not (isExternalName (idName var))
+  = matchSinglePatVar var ctx pat ty match_result
 
 matchSinglePat scrut hs_ctx pat ty match_result
-  = do { var <- selectSimpleMatchVarL pat
-       ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result
+  = do { var           <- selectSimpleMatchVarL pat
+       ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result
        ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
 
-getMaybeStrictPat :: DynFlags -> LPat Id -> Pat Id
-getMaybeStrictPat dflags pat =
-  let (is_strict, pat') = getUnBangedLPat dflags pat
-  in if is_strict then BangPat pat' else unLoc pat'
+matchSinglePatVar :: Id   -- See Note [Match Ids]
+                  -> HsMatchContext Name -> LPat GhcTc
+                  -> Type -> MatchResult -> DsM MatchResult
+matchSinglePatVar var ctx pat ty match_result
+  = ASSERT2( isInternalName (idName var), ppr var )
+    do { dflags <- getDynFlags
+       ; locn   <- getSrcSpanDs
+
+                    -- Pattern match check warnings
+       ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)
+
+       ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
+                                , eqn_rhs  = match_result }
+       ; match [var] ty [eqn_info] }
 
 
 {-
@@ -805,43 +825,77 @@ data PatGroup
   | PgCon DataCon       -- Constructor patterns (incl list, tuple)
   | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]
   | PgLit Literal       -- Literal patterns
-  | PgN   Literal       -- Overloaded literals
-  | PgNpK Literal       -- n+k patterns
+  | PgN   Rational      -- Overloaded numeric literals;
+                        -- see Note [Don't use Literal for PgN]
+  | PgOverS FastString  -- Overloaded string literals
+  | PgNpK Integer       -- n+k patterns
   | PgBang              -- Bang patterns
   | PgCo Type           -- Coercion patterns; the type is the type
                         --      of the pattern *inside*
-  | PgView (LHsExpr Id) -- view pattern (e -> p):
+  | PgView (LHsExpr GhcTc) -- view pattern (e -> p):
                         -- the LHsExpr is the expression e
            Type         -- the Type is the type of p (equivalently, the result type of e)
   | PgOverloadedList
 
+{- Note [Don't use Literal for PgN]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Previously we had, as PatGroup constructors
+
+  | ...
+  | PgN   Literal       -- Overloaded literals
+  | PgNpK Literal       -- n+k patterns
+  | ...
+
+But Literal is really supposed to represent an *unboxed* literal, like Int#.
+We were sticking the literal from, say, an overloaded numeric literal pattern
+into a MachInt constructor. This didn't really make sense; and we now have
+the invariant that value in a MachInt must be in the range of the target
+machine's Int# type, and an overloaded literal could meaningfully be larger.
+
+Solution: For pattern grouping purposes, just store the literal directly in
+the PgN constructor as a Rational if numeric, and add a PgOverStr constructor
+for overloaded strings.
+-}
+
 groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]
 -- If the result is of form [g1, g2, g3],
 -- (a) all the (pg,eq) pairs in g1 have the same pg
 -- (b) none of the gi are empty
 -- The ordering of equations is unchanged
 groupEquations dflags eqns
-  = runs same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]
+  = groupBy same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]
   where
     same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
     (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
 
-subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
+subGroup :: (m -> [[EquationInfo]]) -- Map.elems
+         -> m -- Map.empty
+         -> (a -> m -> Maybe [EquationInfo]) -- Map.lookup
+         -> (a -> [EquationInfo] -> m -> m) -- Map.insert
+         -> [(a, EquationInfo)] -> [[EquationInfo]]
 -- Input is a particular group.  The result sub-groups the
 -- equations by with particular constructor, literal etc they match.
 -- Each sub-list in the result has the same PatGroup
 -- See Note [Take care with pattern order]
-subGroup group
-    = map reverse $ Map.elems $ foldl accumulate Map.empty group
+-- Parameterized by map operations to allow different implementations
+-- and constraints, eg. types without Ord instance.
+subGroup elems empty lookup insert group
+    = map reverse $ elems $ foldl accumulate empty group
   where
     accumulate pg_map (pg, eqn)
-      = case Map.lookup pg pg_map of
-          Just eqns -> Map.insert pg (eqn:eqns) pg_map
-          Nothing   -> Map.insert pg [eqn]      pg_map
-
+      = case lookup pg pg_map of
+          Just eqns -> insert pg (eqn:eqns) pg_map
+          Nothing   -> insert pg [eqn]      pg_map
     -- pg_map :: Map a [EquationInfo]
     -- Equations seen so far in reverse order of appearance
 
+subGroupOrd :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
+subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert
+
+subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [[EquationInfo]]
+subGroupUniq =
+  subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v)
+
 {- Note [Pattern synonym groups]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If we see
@@ -883,6 +937,7 @@ sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2
                                                 -- eqTypes: See Note [Pattern synonym groups]
 sameGroup (PgLit _)     (PgLit _)     = True    -- One case expression
 sameGroup (PgN l1)      (PgN l2)      = l1==l2  -- Order is significant
+sameGroup (PgOverS s1)  (PgOverS s2)  = s1==s2
 sameGroup (PgNpK l1)    (PgNpK l2)    = l1==l2  -- See Note [Grouping overloaded literal patterns]
 sameGroup (PgCo t1)     (PgCo t2)     = t1 `eqType` t2
         -- CoPats are in the same goup only if the type of the
@@ -906,27 +961,28 @@ sameGroup _          _          = False
 -- NB we can't assume that the two view expressions have the same type.  Consider
 --   f (e1 -> True) = ...
 --   f (e2 -> "hi") = ...
-viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool
+viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool
 viewLExprEq (e1,_) (e2,_) = lexp e1 e2
   where
-    lexp :: LHsExpr Id -> LHsExpr Id -> Bool
+    lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
     lexp e e' = exp (unLoc e) (unLoc e')
 
     ---------
-    exp :: HsExpr Id -> HsExpr Id -> Bool
+    exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
     -- real comparison is on HsExpr's
     -- strip parens
-    exp (HsPar (L _ e)) e'   = exp e e'
-    exp e (HsPar (L _ e'))   = exp e e'
+    exp (HsPar (L _ e)) e'   = exp e e'
+    exp e (HsPar (L _ e'))   = exp e e'
     -- because the expressions do not necessarily have the same type,
     -- we have to compare the wrappers
-    exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
-    exp (HsVar i) (HsVar i') =  i == i'
+    exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e'
+    exp (HsVar _ i) (HsVar _ i') =  i == i'
+    exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c'
     -- the instance for IPName derives using the id, so this works if the
     -- above does
-    exp (HsIPVar i) (HsIPVar i') = i == i'
-    exp (HsOverLabel l) (HsOverLabel l') = l == l'
-    exp (HsOverLit l) (HsOverLit l') =
+    exp (HsIPVar _ i) (HsIPVar _ i') = i == i'
+    exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x'
+    exp (HsOverLit _ l) (HsOverLit _ l') =
         -- Overloaded lits are equal if they have the same type
         -- and the data is the same.
         -- this is coarser than comparing the SyntaxExpr's in l and l',
@@ -934,19 +990,20 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
         -- because these expressions get written as a bunch of different variables
         -- (presumably to improve sharing)
         eqType (overLitType l) (overLitType l') && l == l'
-    exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
+    exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'
     -- the fixities have been straightened out by now, so it's safe
     -- to ignore them?
-    exp (OpApp l o _ ri) (OpApp l' o' _ ri') =
+    exp (OpApp _ l o ri) (OpApp _ l' o' ri') =
         lexp l l' && lexp o o' && lexp ri ri'
-    exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n'
-    exp (SectionL e1 e2) (SectionL e1' e2') =
+    exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'
+    exp (SectionL _ e1 e2) (SectionL _ e1' e2') =
         lexp e1 e1' && lexp e2 e2'
-    exp (SectionR e1 e2) (SectionR e1' e2') =
+    exp (SectionR _ e1 e2) (SectionR _ e1' e2') =
         lexp e1 e1' && lexp e2 e2'
-    exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
+    exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) =
         eq_list tup_arg es1 es2
-    exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =
+    exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e'
+    exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') =
         lexp e e' && lexp e1 e1' && lexp e2 e2'
 
     -- Enhancement: could implement equality for more expressions
@@ -956,8 +1013,20 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     exp _ _  = False
 
     ---------
-    tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2
-    tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2
+    syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool
+    syn_exp (SyntaxExpr { syn_expr      = expr1
+                        , syn_arg_wraps = arg_wraps1
+                        , syn_res_wrap  = res_wrap1 })
+            (SyntaxExpr { syn_expr      = expr2
+                        , syn_arg_wraps = arg_wraps2
+                        , syn_res_wrap  = res_wrap2 })
+      = exp expr1 expr2 &&
+        and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) &&
+        wrap res_wrap1 res_wrap2
+
+    ---------
+    tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2
+    tup_arg (L _ (Missing t1))   (L _ (Missing t2))   = eqType t1 t2
     tup_arg _ _ = False
 
     ---------
@@ -970,7 +1039,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     --        equating different ways of writing a coercion)
     wrap WpHole WpHole = True
     wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
-    wrap (WpFun w1 w2 _)   (WpFun w1' w2' _)   = wrap w1 w1' && wrap w2 w2'
+    wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2'
     wrap (WpCast co)       (WpCast co')        = co `eqCoercion` co'
     wrap (WpEvApp et1)     (WpEvApp et2)       = et1 `ev_term` et2
     wrap (WpTyApp t)       (WpTyApp t')        = eqType t t'
@@ -980,8 +1049,8 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
 
     ---------
     ev_term :: EvTerm -> EvTerm -> Bool
-    ev_term (EvId a)       (EvId b)       = a==b
-    ev_term (EvCoercion a) (EvCoercion b) = a `eqCoercion` b
+    ev_term (EvExpr (Var a)) (EvExpr  (Var b)) = a==b
+    ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) = a `eqCoercion` b
     ev_term _ _ = False
 
     ---------
@@ -991,19 +1060,30 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     eq_list _  (_:_)  []     = False
     eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
 
-patGroup :: DynFlags -> Pat Id -> PatGroup
+patGroup :: DynFlags -> Pat GhcTc -> PatGroup
 patGroup _ (ConPatOut { pat_con = L _ con
                       , pat_arg_tys = tys })
  | RealDataCon dcon <- con              = PgCon dcon
  | PatSynCon psyn <- con                = PgSyn psyn tys
 patGroup _ (WildPat {})                 = PgAny
 patGroup _ (BangPat {})                 = PgBang
-patGroup _ (NPat (L _ olit) mb_neg _)   = PgN   (hsOverLitKey olit (isJust mb_neg))
-patGroup _ (NPlusKPat _ (L _ olit) _ _) = PgNpK (hsOverLitKey olit False)
-patGroup _ (CoPat _ p _)                = PgCo  (hsPatType p) -- Type of innelexp pattern
-patGroup _ (ViewPat expr p _)           = PgView expr (hsPatType (unLoc p))
-patGroup _ (ListPat _ _ (Just _))       = PgOverloadedList
-patGroup dflags (LitPat lit)            = PgLit (hsLitKey dflags lit)
+patGroup _ (NPat _ (L _ OverLit {ol_val=oval}) mb_neg _) =
+  case (oval, isJust mb_neg) of
+   (HsIntegral   i, False) -> PgN (fromInteger (il_value i))
+   (HsIntegral   i, True ) -> PgN (-fromInteger (il_value i))
+   (HsFractional r, False) -> PgN (fl_value r)
+   (HsFractional r, True ) -> PgN (-fl_value r)
+   (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
+                          PgOverS s
+patGroup _ (NPlusKPat _ _ (L _ OverLit {ol_val=oval}) _ _ _) =
+  case oval of
+   HsIntegral i -> PgNpK (il_value i)
+   _ -> pprPanic "patGroup NPlusKPat" (ppr oval)
+patGroup _ (CoPat _ _ p _)              = PgCo  (hsPatType p)
+                                                    -- Type of innelexp pattern
+patGroup _ (ViewPat _ expr p)           = PgView expr (hsPatType (unLoc p))
+patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList
+patGroup dflags (LitPat _ lit)          = PgLit (hsLitKey dflags lit)
 patGroup _ pat                          = pprPanic "patGroup" (ppr pat)
 
 {-