Use HsExpansion for overloaded list patterns

Fixes #14380, #19997

15 files changed, 413 insertions, 229 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 72ac021e45..24b8247b32 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -889,8 +889,9 @@ instance Outputable (HsPragE (GhcPass p)) where
 {- Note [Rebindable syntax and HsExpansion]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We implement rebindable syntax (RS) support by performing a desugaring
-in the renamer. We transform GhcPs expressions affected by RS into the
-appropriate desugared form, but **annotated with the original expression**.
+in the renamer. We transform GhcPs expressions and patterns affected by
+RS into the appropriate desugared form, but **annotated with the original
+expression/pattern**.
 
 Let us consider a piece of code like:
 
@@ -981,18 +982,24 @@ tcl_in_gen_code Bool to False.
 
 ---
 
+An overview of the constructs that are desugared in this way is laid out in
+Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr.
+
 A general recipe to follow this approach for new constructs could go as follows:
 
 - Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your
   construct, in HsExpr or related syntax data types.
 - At renaming-time:
     - take your original node of interest (HsIf above)
-    - rename its subexpressions (condition, true branch, false branch above)
+    - rename its subexpressions/subpatterns (condition and true/false
+      branches above)
     - construct the suitable "rebound"-and-renamed result (ifThenElse call
       above), where the 'SrcSpan' attached to any _fabricated node_ (the
       HsVar/HsApp nodes, above) is set to 'generatedSrcSpan'
     - take both the original node and that rebound-and-renamed result and wrap
-      them in an XExpr: XExpr (HsExpanded <original node> <desugared>)
+      them into an expansion construct:
+        for expressions, XExpr (HsExpanded <original node> <desugared>)
+        for patterns, XPat (HsPatExpanded <original node> <desugared>)
  - At typechecking-time:
     - remove any logic that was previously dealing with your rebindable
       construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends.
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 4ec53aeaf0..87f1ceafff 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -421,11 +421,8 @@ deriving instance Data (Pat GhcPs)
 deriving instance Data (Pat GhcRn)
 deriving instance Data (Pat GhcTc)
 
-deriving instance Data CoPat
 deriving instance Data ConPatTc
 
-deriving instance Data ListPatTc
-
 deriving instance (Data a, Data b) => Data (HsFieldBind a b)
 
 deriving instance (Data body) => Data (HsRecFields GhcPs body)
@@ -529,6 +526,7 @@ deriving instance Eq (IE GhcTc)
 -- ---------------------------------------------------------------------
 
 deriving instance Data XXExprGhcTc
+deriving instance Data XXPatGhcTc
 
 -- ---------------------------------------------------------------------
 
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 3f856ec06d..f300c4a2ca 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -23,9 +23,9 @@ module GHC.Hs.Pat (
         Pat(..), LPat,
         EpAnnSumPat(..),
         ConPatTc (..),
-        CoPat (..),
-        ListPatTc(..),
         ConLikeP,
+        HsPatExpansion(..),
+        XXPatGhcTc(..),
 
         HsConPatDetails, hsConPatArgs,
         HsRecFields(..), HsFieldBind(..), LHsFieldBind,
@@ -51,7 +51,7 @@ module GHC.Hs.Pat (
 import GHC.Prelude
 
 import Language.Haskell.Syntax.Pat
-import Language.Haskell.Syntax.Expr (SyntaxExpr)
+import Language.Haskell.Syntax.Expr ( HsExpr )
 
 import {-# SOURCE #-} GHC.Hs.Expr (pprLExpr, pprSplice)
 
@@ -85,11 +85,6 @@ import Data.Data
 import Data.Void
 
 
-data ListPatTc
-  = ListPatTc
-      Type                             -- The type of the elements
-      (Maybe (Type, SyntaxExpr GhcTc)) -- For rebindable syntax
-
 type instance XWildPat GhcPs = NoExtField
 type instance XWildPat GhcRn = NoExtField
 type instance XWildPat GhcTc = Type
@@ -110,12 +105,15 @@ type instance XBangPat GhcPs = EpAnn [AddEpAnn] -- For '!'
 type instance XBangPat GhcRn = NoExtField
 type instance XBangPat GhcTc = NoExtField
 
--- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap
--- compiler, as it triggers https://gitlab.haskell.org/ghc/ghc/issues/14396 for
--- `SyntaxExpr`
 type instance XListPat GhcPs = EpAnn AnnList
-type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn)
-type instance XListPat GhcTc = ListPatTc
+  -- After parsing, ListPat can refer to a built-in Haskell list pattern
+  -- or an overloaded list pattern.
+type instance XListPat GhcRn = NoExtField
+  -- Built-in list patterns only.
+  -- After renaming, overloaded list patterns are expanded to view patterns.
+  -- See Note [Desugaring overloaded list patterns]
+type instance XListPat GhcTc = Type
+  -- List element type, for use in hsPatType.
 
 type instance XTuplePat GhcPs = EpAnn [AddEpAnn]
 type instance XTuplePat GhcRn = NoExtField
@@ -130,8 +128,14 @@ type instance XConPat GhcRn = NoExtField
 type instance XConPat GhcTc = ConPatTc
 
 type instance XViewPat GhcPs = EpAnn [AddEpAnn]
-type instance XViewPat GhcRn = NoExtField
+type instance XViewPat GhcRn = Maybe (HsExpr GhcRn)
+  -- The @HsExpr GhcRn@ gives an inverse to the view function.
+  -- This is used for overloaded lists in particular.
+  -- See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn.
+
 type instance XViewPat GhcTc = Type
+  -- Overall type of the pattern
+  -- (= the argument type of the view function), for hsPatType.
 
 type instance XSplicePat GhcPs = NoExtField
 type instance XSplicePat GhcRn = NoExtField
@@ -152,9 +156,13 @@ type instance XSigPat GhcRn = NoExtField
 type instance XSigPat GhcTc = Type
 
 type instance XXPat GhcPs = NoExtCon
-type instance XXPat GhcRn = NoExtCon
-type instance XXPat GhcTc = CoPat
-  -- After typechecking, we add one extra constructor: CoPat
+type instance XXPat GhcRn = HsPatExpansion (Pat GhcRn) (Pat GhcRn)
+  -- Original pattern and its desugaring/expansion.
+  -- See Note [Rebindable syntax and HsExpansion].
+type instance XXPat GhcTc = XXPatGhcTc
+  -- After typechecking, we add extra constructors: CoPat and HsExpansion.
+  -- HsExpansion allows us to handle RebindableSyntax in pattern position:
+  -- see "XXExpr GhcTc" for the counterpart in expressions.
 
 type instance ConLikeP GhcPs = RdrName -- IdP GhcPs
 type instance ConLikeP GhcRn = Name    -- IdP GhcRn
@@ -174,6 +182,35 @@ data EpAnnSumPat = EpAnnSumPat
 
 -- ---------------------------------------------------------------------
 
+-- | Extension constructor for Pat, added after typechecking.
+data XXPatGhcTc
+  = -- | Coercion Pattern (translation only)
+    --
+    -- During desugaring a (CoPat co pat) turns into a cast with 'co' on the
+    -- scrutinee, followed by a match on 'pat'.
+    CoPat
+      { -- | Coercion Pattern
+        -- If co :: t1 ~ t2, p :: t2,
+        -- then (CoPat co p) :: t1
+        co_cpt_wrap :: HsWrapper
+
+      , -- | Why not LPat?  Ans: existing locn will do
+        co_pat_inner :: Pat GhcTc
+
+      , -- | Type of whole pattern, t1
+        co_pat_ty :: Type
+      }
+  -- | Pattern expansion: original pattern, and desugared pattern,
+  -- for RebindableSyntax and other overloaded syntax such as OverloadedLists.
+  -- See Note [Rebindable syntax and HsExpansion].
+  | ExpansionPat (Pat GhcRn) (Pat GhcTc)
+
+
+-- See Note [Rebindable syntax and HsExpansion].
+data HsPatExpansion a b
+  = HsPatExpanded a b
+  deriving Data
+
 -- | This is the extension field for ConPat, added after typechecking
 -- It adds quite a few extra fields, to support elaboration of pattern matching.
 data ConPatTc
@@ -202,24 +239,6 @@ data ConPatTc
       cpt_wrap  :: HsWrapper
     }
 
--- | Coercion Pattern (translation only)
---
--- During desugaring a (CoPat co pat) turns into a cast with 'co' on the
--- scrutinee, followed by a match on 'pat'.
-data CoPat
-  = CoPat
-    { -- | Coercion Pattern
-      -- If co :: t1 ~ t2, p :: t2,
-      -- then (CoPat co p) :: t1
-      co_cpt_wrap :: HsWrapper
-
-    , -- | Why not LPat?  Ans: existing locn will do
-      co_pat_inner :: Pat GhcTc
-
-    , -- | Type of whole pattern, t1
-      co_pat_ty :: Type
-    }
-
 hsRecFieldId :: HsRecField GhcTc arg -> Id
 hsRecFieldId = hsRecFieldSel
 
@@ -244,6 +263,10 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hfbLHS
 instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where
     ppr = pprPat
 
+-- See Note [Rebindable syntax and HsExpansion].
+instance (Outputable a, Outputable b) => Outputable (HsPatExpansion a b) where
+  ppr (HsPatExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a)
+
 pprLPat :: (OutputableBndrId p) => LPat (GhcPass p) -> SDoc
 pprLPat (L _ e) = pprPat e
 
@@ -270,8 +293,7 @@ pprParendPat p pat = sdocOption sdocPrintTypecheckerElaboration $ \ print_tc_ela
   where
     need_parens print_tc_elab pat
       | GhcTc <- ghcPass @p
-      , XPat ext <- pat
-      , CoPat {} <- ext
+      , XPat (CoPat {}) <- pat
       = print_tc_elab
 
       | otherwise
@@ -335,13 +357,16 @@ pprPat (ConPat { pat_con = con
 pprPat (XPat ext) = case ghcPass @p of
 #if __GLASGOW_HASKELL__ < 811
   GhcPs -> noExtCon ext
-  GhcRn -> noExtCon ext
 #endif
-  GhcTc -> pprHsWrapper co $ \parens ->
-      if parens
-      then pprParendPat appPrec pat
-      else pprPat pat
-    where CoPat co pat _ = ext
+  GhcRn -> case ext of
+    HsPatExpanded orig _ -> pprPat orig
+  GhcTc -> case ext of
+    CoPat co pat _ ->
+      pprHsWrapper co $ \parens ->
+        if parens
+        then pprParendPat appPrec pat
+        else pprPat pat
+    ExpansionPat orig _ -> pprPat orig
 
 pprUserCon :: (OutputableBndr con, OutputableBndrId p,
                      Outputable (Anno (IdGhcP p)))
@@ -543,10 +568,12 @@ isIrrefutableHsPat' is_strict = goL
     go (XPat ext)          = case ghcPass @p of
 #if __GLASGOW_HASKELL__ < 811
       GhcPs -> noExtCon ext
-      GhcRn -> noExtCon ext
 #endif
-      GhcTc -> go pat
-        where CoPat _ pat _ = ext
+      GhcRn -> case ext of
+        HsPatExpanded _ pat -> go pat
+      GhcTc -> case ext of
+        CoPat _ pat _ -> go pat
+        ExpansionPat _ pat -> go pat
 
 -- | Is the pattern any of combination of:
 --
@@ -590,22 +617,28 @@ is the only thing that could possibly be matched!
 -- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs
 -- parentheses under precedence @p@.
 patNeedsParens :: forall p. IsPass p => PprPrec -> Pat (GhcPass p) -> Bool
-patNeedsParens p = go
+patNeedsParens p = go @p
   where
-    go :: Pat (GhcPass p) -> Bool
+    -- Remark: go needs to be polymorphic, as we call it recursively
+    -- at a different GhcPass (see the case for GhcTc XPat below).
+    go :: forall q. IsPass q => Pat (GhcPass q) -> Bool
     go (NPlusKPat {})    = p > opPrec
     go (SplicePat {})    = False
     go (ConPat { pat_args = ds })
                          = conPatNeedsParens p ds
     go (SigPat {})       = p >= sigPrec
     go (ViewPat {})      = True
-    go (XPat ext)        = case ghcPass @p of
+    go (XPat ext)        = case ghcPass @q of
 #if __GLASGOW_HASKELL__ < 901
       GhcPs -> noExtCon ext
-      GhcRn -> noExtCon ext
 #endif
-      GhcTc -> go inner
-        where CoPat _ inner _ = ext
+      GhcRn -> case ext of
+        HsPatExpanded orig _ -> go orig
+      GhcTc -> case ext of
+        CoPat _ inner _ -> go inner
+        ExpansionPat orig _ -> go orig
+          --                   ^^^^^^^
+          -- NB: recursive call of go at a different GhcPass.
     go (WildPat {})      = False
     go (VarPat {})       = False
     go (LazyPat {})      = False
@@ -679,7 +712,9 @@ collectEvVarsPat pat =
                                    $ map collectEvVarsLPat
                                    $ hsConPatArgs args
     SigPat  _ p _    -> collectEvVarsLPat p
-    XPat (CoPat _ p _) -> collectEvVarsPat  p
+    XPat ext -> case ext of
+      CoPat _ p _      -> collectEvVarsPat p
+      ExpansionPat _ p -> collectEvVarsPat p
     _other_pat       -> emptyBag
 
 {-
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
index 6428a99ff4..1c9b1706bd 100644
--- a/compiler/GHC/Hs/Syn/Type.hs
+++ b/compiler/GHC/Hs/Syn/Type.hs
@@ -50,8 +50,7 @@ hsPatType (LazyPat _ pat)               = hsLPatType pat
 hsPatType (LitPat _ lit)                = hsLitType lit
 hsPatType (AsPat _ var _)               = idType (unLoc var)
 hsPatType (ViewPat ty _ _)              = ty
-hsPatType (ListPat (ListPatTc ty Nothing) _)      = mkListTy ty
-hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty
+hsPatType (ListPat ty _)                = mkListTy ty
 hsPatType (TuplePat tys _ bx)           = mkTupleTy1 bx tys
                   -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
 hsPatType (SumPat tys _ _ _ )           = mkSumTy tys
@@ -64,7 +63,10 @@ hsPatType (ConPat { pat_con = lcon
 hsPatType (SigPat ty _ _)               = ty
 hsPatType (NPat ty _ _ _)               = ty
 hsPatType (NPlusKPat ty _ _ _ _ _)      = ty
-hsPatType (XPat (CoPat _ _ ty))         = ty
+hsPatType (XPat ext) =
+  case ext of
+    CoPat _ _ ty       -> ty
+    ExpansionPat _ pat -> hsPatType pat
 hsPatType (SplicePat v _)               = dataConCantHappen v
 
 hsLitType :: HsLit (GhcPass p) -> Type
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 42ea9f0ae7..590cf87793 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -1240,9 +1240,13 @@ class UnXRec p => CollectPass p where
 instance IsPass p => CollectPass (GhcPass p) where
   collectXXPat _ flag ext =
     case ghcPass @p of
-      GhcTc -> let CoPat _ pat _ = ext in collect_pat flag pat
-      GhcRn -> noExtCon ext
       GhcPs -> noExtCon ext
+      GhcRn
+        | HsPatExpanded _ pat <- ext
+        -> collect_pat flag pat
+      GhcTc -> case ext of
+        CoPat _ pat _      -> collect_pat flag pat
+        ExpansionPat _ pat -> collect_pat flag pat
 
 {-
 Note [Dictionary binders in ConPatOut]
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index 6576add1a2..67a478907c 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -1,7 +1,9 @@
 
 {-# LANGUAGE MonadComprehensions #-}
 {-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -23,7 +25,7 @@ where
 import GHC.Prelude
 import GHC.Platform
 
-import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr)
+import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
 
 import GHC.Types.Basic ( Origin(..), isGenerated, Boxity(..) )
 import GHC.Types.SourceText
@@ -232,7 +234,6 @@ match (v:vs) ty eqns    -- Eqns *can* be empty
             PgBang    -> matchBangs      vars ty (dropGroup eqns)
             PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)
             PgView {} -> matchView       vars ty (dropGroup eqns)
-            PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)
       where eqns' = NEL.toList eqns
             ne l = case NEL.nonEmpty l of
               Just nel -> nel
@@ -289,46 +290,42 @@ 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 TcViewPat viewExpr pat = firstPat eqn1
          -- do the rest of the compilation
         ; let pat_ty' = hsPatType pat
         ; var' <- newUniqueId var (idMult var) pat_ty'
         ; match_result <- match (var':vars) ty $ NEL.toList $
             decomposeFirstPat getViewPat <$> eqns
          -- compile the view expressions
-        ; viewExpr' <- dsLExpr viewExpr
+        ; viewExpr' <- dsExpr viewExpr
         ; return (mkViewMatchResult var'
                     (mkCoreAppDs (text "matchView") viewExpr' (Var var))
                     match_result) }
 
-matchOverloadedList :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
-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 (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1
-       ; var' <- newUniqueId var (idMult var) (mkListTy elt_ty)  -- we construct the overall type by hand
-       ; match_result <- match (var':vars) ty $ NEL.toList $
-           decomposeFirstPat getOLPat <$> eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
-       ; e' <- dsSyntaxExpr e [Var var]
-       ; return (mkViewMatchResult var' e' match_result)
-       }
-
 -- decompose the first pattern and leave the rest alone
 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 GhcTc -> Pat GhcTc
+getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc
 getCoPat (XPat (CoPat _ pat _)) = pat
 getCoPat _                   = panic "getCoPat"
 getBangPat (BangPat _ pat  ) = unLoc pat
 getBangPat _                 = panic "getBangPat"
-getViewPat (ViewPat _ _ pat) = unLoc pat
+getViewPat (TcViewPat _ pat) = pat
 getViewPat _                 = panic "getViewPat"
-getOLPat (ListPat (ListPatTc ty (Just _)) pats)
-        = ListPat (ListPatTc ty Nothing)  pats
-getOLPat _                   = panic "getOLPat"
+
+-- | Use this pattern synonym to match on a 'ViewPat'.
+--
+-- N.B.: View patterns can occur inside HsExpansions.
+pattern TcViewPat :: HsExpr GhcTc -> Pat GhcTc -> Pat GhcTc
+pattern TcViewPat viewExpr pat <- (getTcViewPat -> (viewExpr, pat))
+
+getTcViewPat :: Pat GhcTc -> (HsExpr GhcTc, Pat GhcTc)
+getTcViewPat (ViewPat _ viewLExpr pat)  = (unLoc viewLExpr, unLoc pat)
+getTcViewPat (XPat (ExpansionPat  _ p)) = getTcViewPat p
+getTcViewPat p = pprPanic "getTcViewPat" (ppr p)
 
 {-
 Note [Empty case alternatives]
@@ -461,7 +458,7 @@ tidy1 v _ (LazyPat _ pat)
         ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
         ; return (mkCoreLets sel_binds, WildPat (idType v)) }
 
-tidy1 _ _ (ListPat (ListPatTc ty Nothing) pats )
+tidy1 _ _ (ListPat ty pats)
   = return (idDsWrapper, unLoc list_ConPat)
   where
     list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
@@ -907,7 +904,6 @@ data PatGroup
   | 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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1173,11 +1169,11 @@ patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =
   case oval of
    HsIntegral i -> PgNpK (il_value i)
    _ -> pprPanic "patGroup NPlusKPat" (ppr oval)
-patGroup _ (XPat (CoPat _ p _))         = PgCo  (hsPatType p)
-                                                    -- Type of innelexp pattern
 patGroup _ (ViewPat _ expr p)           = PgView expr (hsPatType (unLoc p))
-patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList
 patGroup platform (LitPat _ lit)        = PgLit (hsLitKey platform lit)
+patGroup platform (XPat ext) = case ext of
+  CoPat _ p _      -> PgCo (hsPatType p) -- Type of innelexp pattern
+  ExpansionPat _ p -> patGroup platform p
 patGroup _ pat                          = pprPanic "patGroup" (ppr pat)
 
 {-
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
index fa32d391d2..81d3b1cc51 100644
--- a/compiler/GHC/HsToCore/Pmc/Desugar.hs
+++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs
@@ -122,16 +122,37 @@ desugarPat x pat = case pat of
 
   SigPat _ p _ty -> desugarLPat x p
 
-  -- See Note [Desugar CoPats]
-  -- Generally the translation is
-  -- pat |> co   ===>   let y = x |> co, pat <- y  where y is a match var of pat
-  XPat (CoPat wrapper p _ty)
-    | isIdHsWrapper wrapper                   -> desugarPat x p
-    | WpCast co <-  wrapper, isReflexiveCo co -> desugarPat x p
-    | otherwise -> do
-        (y, grds) <- desugarPatV p
-        wrap_rhs_y <- dsHsWrapper wrapper
-        pure (PmLet y (wrap_rhs_y (Var x)) : grds)
+  XPat ext -> case ext of
+
+    ExpansionPat orig expansion -> do
+      dflags <- getDynFlags
+      case orig of
+        -- We add special logic for overloaded list patterns. When:
+        --   - a ViewPat is the expansion of a ListPat,
+        --   - RebindableSyntax is off,
+        --   - the type of the pattern is the built-in list type,
+        -- then we assume that the view function, 'toList', is the identity.
+        -- This improves pattern-match overload checks, as this will allow
+        -- the pattern match checker to directly inspect the inner pattern.
+        -- See #14547, and Note [Desugaring overloaded list patterns] (Wrinkle).
+        ListPat {}
+          | ViewPat arg_ty _lexpr pat <- expansion
+          , not (xopt LangExt.RebindableSyntax dflags)
+          , Just _ <- splitListTyConApp_maybe arg_ty
+          -> desugarLPat x pat
+
+        _ -> desugarPat x expansion
+
+    -- See Note [Desugar CoPats]
+    -- Generally the translation is
+    -- pat |> co   ===>   let y = x |> co, pat <- y  where y is a match var of pat
+    CoPat wrapper p _ty
+      | isIdHsWrapper wrapper                   -> desugarPat x p
+      | WpCast co <-  wrapper, isReflexiveCo co -> desugarPat x p
+      | otherwise -> do
+          (y, grds) <- desugarPatV p
+          wrap_rhs_y <- dsHsWrapper wrapper
+          pure (PmLet y (wrap_rhs_y (Var x)) : grds)
 
   -- (n + k)  ===>   let b = x >= k, True <- b, let n = x-k
   NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do
@@ -149,37 +170,9 @@ desugarPat x pat = case pat of
     pure $ PmLet y (App fun (Var x)) : grds
 
   -- list
-  ListPat (ListPatTc _elem_ty Nothing) ps ->
+  ListPat _ ps ->
     desugarListPat x ps
 
-  -- overloaded list
-  ListPat (ListPatTc elem_ty (Just (pat_ty, to_list))) pats -> do
-    dflags <- getDynFlags
-    case splitListTyConApp_maybe pat_ty of
-      Just _e_ty
-        | not (xopt LangExt.RebindableSyntax dflags)
-        -- Just desugar it as a regular ListPat
-        -> desugarListPat x pats
-      _ -> do
-        y <- mkPmId (mkListTy elem_ty)
-        grds <- desugarListPat y pats
-        rhs_y <- dsSyntaxExpr to_list [Var x]
-        pure $ PmLet y rhs_y : grds
-
-    -- (a) In the presence of RebindableSyntax, we don't know anything about
-    --     `toList`, we should treat `ListPat` as any other view pattern.
-    --
-    -- (b) In the absence of RebindableSyntax,
-    --     - If the pat_ty is `[a]`, then we treat the overloaded list pattern
-    --       as ordinary list pattern. Although we can give an instance
-    --       `IsList [Int]` (more specific than the default `IsList [a]`), in
-    --       practice, we almost never do that. We assume the `to_list` is
-    --       the `toList` from `instance IsList [a]`.
-    --
-    --     - Otherwise, we treat the `ListPat` as ordinary view pattern.
-    --
-    -- See #14547, especially comment#9 and comment#10.
-
   ConPat { pat_con     = L _ con
          , pat_args    = ps
          , pat_con_ext = ConPatTc
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 0860192e68..71e5ac9655 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -2039,12 +2039,8 @@ repP (LazyPat _ p)      = do { p1 <- repLP p; repPtilde p1 }
 repP (BangPat _ p)      = do { p1 <- repLP p; repPbang p1 }
 repP (AsPat _ x p)      = do { x' <- lookupNBinder x; p1 <- repLP p
                              ; repPaspat x' p1 }
-repP (ParPat _ _ p _)      = repLP p
-repP (ListPat Nothing ps)  = do { qs <- repLPs ps; repPlist qs }
-repP (ListPat (Just (SyntaxExprRn e)) ps) = do { p <- repP (ListPat Nothing ps)
-                                               ; e' <- repE e
-                                               ; repPview e' p}
-repP (ListPat _ ps) = pprPanic "repP missing SyntaxExprRn" (ppr ps)
+repP (ParPat _ _ p _)   = repLP p
+repP (ListPat _ ps)     = do { qs <- repLPs ps; repPlist qs }
 repP (TuplePat _ ps boxed)
   | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }
   | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index f198dc55c1..f4cc42949a 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -1020,14 +1020,14 @@ instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where
         ]
       XPat e ->
         case hiePass @p of
-          HieTc ->
-            let CoPat wrap pat _ = e
-              in [ toHie $ L ospan wrap
-                 , toHie $ PS rsp scope pscope $ (L ospan pat)
-                 ]
-#if __GLASGOW_HASKELL__ < 811
-          HieRn -> []
-#endif
+          HieRn -> case e of
+            HsPatExpanded _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ]
+          HieTc -> case e of
+            CoPat wrap pat _ ->
+              [ toHie $ L ospan wrap
+              , toHie $ PS rsp scope pscope $ (L ospan pat)
+              ]
+            ExpansionPat _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ]
     where
       contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType (NoGhcTc (GhcPass p))) a (HsRecFields (GhcPass p) a)
                  -> HsConDetails (TScoped (HsPatSigType (NoGhcTc (GhcPass p)))) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index ee81957015..cd0707ef59 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -1,8 +1,10 @@
 
 {-# LANGUAGE ConstraintKinds     #-}
+{-# LANGUAGE CPP                 #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE MultiWayIf          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeFamilies        #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -40,7 +42,10 @@ import GHC.Rename.Utils ( HsDocContext(..), bindLocalNamesFV, checkDupNames
                         , bindLocalNames
                         , mapMaybeFvRn, mapFvRn
                         , warnUnusedLocalBinds, typeAppErr
-                        , checkUnusedRecordWildcard )
+                        , checkUnusedRecordWildcard
+                        , wrapGenSpan, genHsIntegralLit, genHsTyLit
+                        , genHsVar, genLHsVar, genHsApp, genHsApps
+                        , genAppType )
 import GHC.Rename.Unbound ( reportUnboundName )
 import GHC.Rename.Splice  ( rnBracket, rnSpliceExpr, checkThLocalName )
 import GHC.Rename.HsType
@@ -63,7 +68,6 @@ import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 import GHC.Utils.Outputable as Outputable
 import GHC.Types.SrcLoc
-import GHC.Data.FastString
 import Control.Monad
 import GHC.Builtin.Types ( nilDataConName )
 import qualified GHC.LanguageExtensions as LangExt
@@ -107,7 +111,10 @@ RebindableSyntax:
 This is accomplished by lookupSyntaxName, and it applies to all the
 constructs below.
 
-Here are the constructs that we transform in this way. Some are uniform,
+See also Note [Handling overloaded and rebindable patterns] in GHC.Rename.Pat
+for the story with patterns.
+
+Here are the expressions that we transform in this way. Some are uniform,
 but several have a little bit of special treatment:
 
 * HsIf (if-the-else)
@@ -397,7 +404,7 @@ rnExpr (ExplicitList _ exps)
     do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
        ; let rn_list  = ExplicitList noExtField exps'
              lit_n    = mkIntegralLit (length exps)
-             hs_lit   = wrapGenSpan (HsLit noAnn (HsInt noExtField lit_n))
+             hs_lit   = genHsIntegralLit lit_n
              exp_list = genHsApps from_list_n_name [hs_lit, wrapGenSpan rn_list]
        ; return ( mkExpandedExpr rn_list exp_list
                 , fvs `plusFV` fvs') } }
@@ -2146,9 +2153,9 @@ parallel" in an ApplicativeStmt, but doesn't otherwise affect what we
 can do with the rest of the statements in the same "do" expression.
 -}
 
-isStrictPattern :: LPat (GhcPass p) -> Bool
-isStrictPattern lpat =
-  case unLoc lpat of
+isStrictPattern :: forall p. IsPass p => LPat (GhcPass p) -> Bool
+isStrictPattern (L loc pat) =
+  case pat of
     WildPat{}       -> False
     VarPat{}        -> False
     LazyPat{}       -> False
@@ -2165,7 +2172,16 @@ isStrictPattern lpat =
     NPat{}          -> True
     NPlusKPat{}     -> True
     SplicePat{}     -> True
-    XPat{}          -> panic "isStrictPattern: XPat"
+    XPat ext        -> case ghcPass @p of
+#if __GLASGOW_HASKELL__ < 811
+      GhcPs -> noExtCon ext
+#endif
+      GhcRn
+        | HsPatExpanded _ p <- ext
+        -> isStrictPattern (L loc p)
+      GhcTc -> case ext of
+        ExpansionPat _ p -> isStrictPattern (L loc p)
+        CoPat {} -> panic "isStrictPattern: CoPat"
 
 {-
 Note [ApplicativeDo and refutable patterns]
@@ -2560,29 +2576,6 @@ getMonadFailOp ctxt
 *                                                                      *
 ********************************************************************* -}
 
-genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
-genHsApps fun args = foldl genHsApp (genHsVar fun) args
-
-genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
-genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg
-
-genLHsVar :: Name -> LHsExpr GhcRn
-genLHsVar nm = wrapGenSpan $ genHsVar nm
-
-genHsVar :: Name -> HsExpr GhcRn
-genHsVar nm = HsVar noExtField $ wrapGenSpan nm
-
-genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn
-genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs . wrapGenSpan
-
-genHsTyLit :: FastString -> HsType GhcRn
-genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText
-
-wrapGenSpan :: a -> LocatedAn an a
--- Wrap something in a "generatedSrcSpan"
--- See Note [Rebindable syntax and HsExpansion]
-wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x
-
 -- | Build a 'HsExpansion' out of an extension constructor,
 --   and the two components of the expansion: original and
 --   desugared expressions.
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 524b63c49f..606c9a372b 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -57,7 +57,8 @@ import GHC.Rename.Fixity
 import GHC.Rename.Utils    ( HsDocContext(..), newLocalBndrRn, bindLocalNames
                            , warnUnusedMatches, newLocalBndrRn
                            , checkUnusedRecordWildcard
-                           , checkDupNames, checkDupAndShadowedNames )
+                           , checkDupNames, checkDupAndShadowedNames
+                           , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit )
 import GHC.Rename.HsType
 import GHC.Builtin.Names
 import GHC.Types.Avail ( greNameMangledName )
@@ -296,6 +297,85 @@ pattern P x = Just x
 
 See #12615 for some more examples.
 
+Note [Handling overloaded and rebindable patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Overloaded paterns and rebindable patterns are desugared in the renamer
+using the HsPatExpansion mechanism detailed in:
+Note [Rebindable syntax and HsExpansion]
+The approach is similar to that of expressions, which is further detailed
+in Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr.
+
+Here are the patterns that are currently desugared in this way:
+
+* ListPat (list patterns [p1,p2,p3])
+  When (and only when) OverloadedLists is on, desugar to a view pattern:
+    [p1, p2, p3]
+  ==>
+    toList -> [p1, p2, p3]
+              ^^^^^^^^^^^^ built-in (non-overloaded) list pattern
+  NB: the type checker and desugarer still see ListPat,
+      but to them it always means the built-in list pattern.
+  See Note [Desugaring overloaded list patterns] below for more details.
+
+We expect to add to this list as we deal with more patterns via the expansion
+mechanism.
+
+Note [Desugaring overloaded list patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If OverloadedLists is enabled, we desugar a list pattern to a view pattern:
+
+  [p1, p2, p3]
+==>
+  toList -> [p1, p2, p3]
+
+This happens directly in the renamer, using the HsPatExpansion mechanism
+detailed in Note [Rebindable syntax and HsExpansion].
+
+Note that we emit a special view pattern: we additionally keep track of an
+inverse to the pattern.
+See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn for details.
+
+== Wrinkle ==
+
+This is all fine, except in one very specific case:
+  - when RebindableSyntax is off,
+  - and the type being matched on is already a list type.
+
+In this case, it is undesirable to desugar an overloaded list pattern into
+a view pattern. To illustrate, consider the following program:
+
+> {-# LANGUAGE OverloadedLists #-}
+>
+> f []    = True
+> f (_:_) = False
+
+Without any special logic, the pattern `[]` is desugared to `(toList -> [])`,
+whereas `(_:_)` remains a constructor pattern. This implies that the argument
+of `f` is necessarily a list (even though `OverloadedLists` is enabled).
+After desugaring the overloaded list pattern `[]`, and type-checking, we obtain:
+
+> f :: [a] -> Bool
+> f (toList -> []) = True
+> f (_:_)          = False
+
+The pattern match checker then warns that the pattern `[]` is not covered,
+as it isn't able to look through view patterns.
+We can see that this is silly: as we are matching on a list, `toList` doesn't
+actually do anything. So we ignore it, and desugar the pattern to an explicit
+list pattern, instead of a view pattern.
+
+Note however that this is not necessarily sound, because it is possible to have
+a list `l` such that `toList l` is not the same as `l`.
+This can happen with an overlapping instance, such as the following:
+
+instance {-# OVERLAPPING #-} IsList [Int] where
+  type Item [Int] = Int
+  toList = reverse
+  fromList = reverse
+
+We make the assumption that no such instance exists, in order to avoid worsening
+pattern-match warnings (see #14547).
+
 *********************************************************
 *                                                      *
         External entry points
@@ -485,7 +565,10 @@ rnPatAndThen mk p@(ViewPat _ expr pat)
        ; pat' <- rnLPatAndThen mk pat
        -- Note: at this point the PreTcType in ty can only be a placeHolder
        -- ; return (ViewPat expr' pat' ty) }
-       ; return (ViewPat noExtField expr' pat') }
+
+       -- Note: we can't cook up an inverse for an arbitrary view pattern,
+       -- so we pass 'Nothing'.
+       ; return (ViewPat Nothing expr' pat') }
 
 rnPatAndThen mk (ConPat _ con args)
    -- rnConPatAndThen takes care of reconstructing the pattern
@@ -497,12 +580,25 @@ rnPatAndThen mk (ConPat _ con args)
       False   -> rnConPatAndThen mk con args
 
 rnPatAndThen mk (ListPat _ pats)
-  = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists
+  = do { opt_OverloadedLists  <- liftCps $ xoptM LangExt.OverloadedLists
        ; pats' <- rnLPatsAndThen mk pats
-       ; case opt_OverloadedLists of
-          True -> do { (to_list_name,_) <- liftCps $ lookupSyntax toListName
-                     ; return (ListPat (Just to_list_name) pats')}
-          False -> return (ListPat Nothing pats') }
+       ; if not opt_OverloadedLists
+         then return (ListPat noExtField pats')
+         else
+    -- If OverloadedLists is enabled, desugar to a view pattern.
+    -- See Note [Desugaring overloaded list patterns]
+    do { (to_list_name,_)     <- liftCps $ lookupSyntaxName toListName
+       -- Use 'fromList' as proof of invertibility of the view pattern.
+       -- See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn
+       ; (from_list_n_name,_) <- liftCps $ lookupSyntaxName fromListNName
+       ; let
+           lit_n   = mkIntegralLit (length pats)
+           hs_lit  = genHsIntegralLit lit_n
+           inverse = genHsApps from_list_n_name [hs_lit]
+           rn_list_pat  = ListPat noExtField pats'
+           exp_expr     = genLHsVar to_list_name
+           exp_list_pat = ViewPat (Just inverse) exp_expr (wrapGenSpan rn_list_pat)
+       ; return $ mkExpandedPat rn_list_pat exp_list_pat }}
 
 rnPatAndThen mk (TuplePat _ pats boxed)
   = do { pats' <- rnLPatsAndThen mk pats
@@ -614,6 +710,23 @@ rnHsRecPatsAndThen mk (L _ con)
     nested_mk (Just (unLoc -> n)) (LamMk report_unused) n'
       = LamMk (report_unused && (n' <= n))
 
+
+{- *********************************************************************
+*                                                                      *
+              Generating code for HsPatExpanded
+      See Note [Handling overloaded and rebindable constructs]
+*                                                                      *
+********************************************************************* -}
+
+-- | Build a 'HsPatExpansion' out of an extension constructor,
+--   and the two components of the expansion: original and
+--   desugared patterns
+mkExpandedPat
+  :: Pat GhcRn -- ^ source pattern
+  -> Pat GhcRn -- ^ expanded pattern
+  -> Pat GhcRn -- ^ suitably wrapped 'HsPatExpansion'
+mkExpandedPat a b = XPat (HsPatExpanded a b)
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index a97d215b8b..bd5c9240e0 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -18,6 +18,8 @@ module GHC.Rename.Utils (
         checkUnusedRecordWildcard,
         mkFieldEnv,
         unknownSubordinateErr, badQualBndrErr, typeAppErr,
+        wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType,
+        genHsIntegralLit, genHsTyLit,
         HsDocContext(..), pprHsDocContext,
         inHsDocContext, withHsDocContext,
 
@@ -49,6 +51,7 @@ import GHC.Types.Name.Env
 import GHC.Core.DataCon
 import GHC.Types.SrcLoc as SrcLoc
 import GHC.Types.SourceFile
+import GHC.Types.SourceText ( SourceText(..), IntegralLit )
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Misc
@@ -646,6 +649,38 @@ checkCTupSize tup_size
                   <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))
                2 (text "Instead, use a nested tuple")
 
+{- *********************************************************************
+*                                                                      *
+              Generating code for HsExpanded
+      See Note [Handling overloaded and rebindable constructs]
+*                                                                      *
+********************************************************************* -}
+
+wrapGenSpan :: a -> LocatedAn an a
+-- Wrap something in a "generatedSrcSpan"
+-- See Note [Rebindable syntax and HsExpansion]
+wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x
+
+genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
+genHsApps fun args = foldl genHsApp (genHsVar fun) args
+
+genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
+genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg
+
+genLHsVar :: Name -> LHsExpr GhcRn
+genLHsVar nm = wrapGenSpan $ genHsVar nm
+
+genHsVar :: Name -> HsExpr GhcRn
+genHsVar nm = HsVar noExtField $ wrapGenSpan nm
+
+genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn
+genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs . wrapGenSpan
+
+genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn)
+genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit)
+
+genHsTyLit :: FastString -> HsType GhcRn
+genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index be5a243dec..10c862f8f6 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -450,7 +450,8 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
                --                (pat_ty -> inf_res_sigma)
               expr_wrap = expr_wrap2' <.> expr_wrap1 <.> mult_wrap
               doc = text "When checking the view pattern function:" <+> (ppr expr)
-        ; return (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res)}
+
+        ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) }
 
 {- Note [View patterns and polymorphism]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -487,25 +488,16 @@ Fortunately that's what matchExpectedFunTySigma returns anyway.
 
 ------------------------
 -- Lists, tuples, arrays
-  ListPat Nothing pats -> do
+
+  -- Necessarily a built-in list pattern, not an overloaded list pattern.
+  -- See Note [Desugaring overloaded list patterns].
+  ListPat _ pats -> do
         { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv (scaledThing pat_ty)
         ; (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty))
                                      penv pats thing_inside
         ; pat_ty <- readExpType (scaledThing pat_ty)
         ; return (mkHsWrapPat coi
-                         (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res)
-}
-
-  ListPat (Just e) pats -> do
-        { tau_pat_ty <- expTypeToType (scaledThing pat_ty)
-        ; ((pats', res, elt_ty), e')
-            <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)]
-                                          SynList $
-                 \ [elt_ty] _ ->
-                 do { (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty))
-                                                 penv pats thing_inside
-                    ; return (pats', res, elt_ty) }
-        ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res)
+                         (ListPat elt_ty pats') pat_ty, res)
 }
 
   TuplePat _ pats boxity -> do
@@ -697,6 +689,9 @@ AST is used for the subtraction operation.
       ; tc_pat pat_ty penv pat thing_inside }
     _ -> panic "invalid splice in splice pat"
 
+  XPat (HsPatExpanded lpat rpat) -> do
+    { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside
+    ; return (XPat $ ExpansionPat lpat rpat', res) }
 
 {-
 Note [Hopping the LIE in lazy patterns]
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index c470258e43..bc78e8b592 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -60,6 +60,7 @@ import GHC.Tc.TyCl.Utils
 import GHC.Core.ConLike
 import GHC.Types.FieldLabel
 import GHC.Rename.Env
+import GHC.Rename.Utils (wrapGenSpan)
 import GHC.Data.Bag
 import GHC.Utils.Misc
 import GHC.Driver.Session ( getDynFlags, xopt_FieldSelectors )
@@ -1027,10 +1028,9 @@ tcPatToExpr name args pat = go pat
         | otherwise
         = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
     go1 (ParPat _ lpar pat rpar) = fmap (\e -> HsPar noAnn lpar e rpar) $ go pat
-    go1 p@(ListPat reb pats)
-      | Nothing <- reb = do { exprs <- mapM go pats
-                            ; return $ ExplicitList noExtField exprs }
-      | otherwise                   = notInvertibleListPat p
+    go1 (ListPat _ pats)
+      = do { exprs <- mapM go pats
+           ; return $ ExplicitList noExtField exprs }
     go1 (TuplePat _ pats box)       = do { exprs <- mapM go pats
                                          ; return $ ExplicitTuple noExtField
                                            (map (Present noAnn) exprs) box }
@@ -1047,13 +1047,21 @@ tcPatToExpr name args pat = go pat
     go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
                                     = go1 pat
     go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"
+    go1 (XPat (HsPatExpanded _ pat))= go1 pat
+
+    -- See Note [Invertible view patterns]
+    go1 p@(ViewPat mbInverse _ pat) = case mbInverse of
+      Nothing      -> notInvertible p
+      Just inverse ->
+        fmap
+          (\ expr -> HsApp noAnn (wrapGenSpan inverse) (wrapGenSpan expr))
+          (go1 (unLoc pat))
 
     -- The following patterns are not invertible.
     go1 p@(BangPat {})                       = notInvertible p -- #14112
     go1 p@(LazyPat {})                       = notInvertible p
     go1 p@(WildPat {})                       = notInvertible p
     go1 p@(AsPat {})                         = notInvertible p
-    go1 p@(ViewPat {})                       = notInvertible p
     go1 p@(NPlusKPat {})                     = notInvertible p
     go1 p@(SplicePat _ (HsTypedSplice {}))   = notInvertible p
     go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p
@@ -1072,27 +1080,23 @@ tcPatToExpr name args pat = go pat
         pp_name = ppr name
         pp_args = hsep (map ppr args)
 
-    -- We should really be able to invert list patterns, even when
-    -- rebindable syntax is on, but doing so involves a bit of
-    -- refactoring; see #14380.  Until then we reject with a
-    -- helpful error message.
-    notInvertibleListPat p
-      = Left (vcat [ not_invertible_msg p
-                   , text "Reason: rebindable syntax is on."
-                   , text "This is fixable: add use-case to #14380" ])
 
 {- Note [Builder for a bidirectional pattern synonym]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For a bidirectional pattern synonym we need to produce an /expression/
-that matches the supplied /pattern/, given values for the arguments
-of the pattern synonym.  For example
+For a bidirectional pattern synonym, the function 'tcPatToExpr'
+needs to produce an /expression/ that matches the supplied /pattern/,
+given values for the arguments of the pattern synonym. For example:
   pattern F x y = (Just x, [y])
 The 'builder' for F looks like
   $builderF x y = (Just x, [y])
 
 We can't always do this:
- * Some patterns aren't invertible; e.g. view patterns
-      pattern F x = (reverse -> x:_)
+ * Some patterns aren't invertible; e.g. general view patterns
+      pattern F x = (f -> x)
+   as we don't have the ability to write down an expression that matches
+   the view pattern specified by an arbitrary view function `f`.
+   It is however sometimes possible to write down an inverse;
+     see Note [Invertible view patterns].
 
  * The RHS pattern might bind more variables than the pattern
    synonym, so again we can't invert it
@@ -1101,6 +1105,21 @@ We can't always do this:
  * Ditto wildcards
       pattern F x = (x,_)
 
+Note [Invertible view patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For some view patterns, such as those that arise from expansion of overloaded
+patterns (as detailed in Note [Handling overloaded and rebindable patterns]),
+we are able to explicitly write out an inverse (in the sense of the previous
+Note [Builder for a bidirectional pattern synonym]).
+For instance, the inverse to the pattern
+
+  (toList -> [True, False])
+
+is the expression
+
+  (fromListN 2 [True,False])
+
+Keeping track of the inverse for such view patterns fixed #14380.
 
 Note [Redundant constraints for builder]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1214,7 +1233,9 @@ tcCollectEx pat = go pat
                            = merge (cpt_tvs con', cpt_dicts con') $
                               goConDetails $ pat_args con
     go1 (SigPat _ p _)     = go p
-    go1 (XPat (CoPat _ p _)) = go1 p
+    go1 (XPat ext) = case ext of
+      CoPat _ p _      -> go1 p
+      ExpansionPat _ p -> go1 p
     go1 (NPlusKPat _ n k _ geq subtract)
       = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
     go1 _                   = empty
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 2a38a54460..49d2885c5e 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -1374,17 +1374,10 @@ zonk_pat env (ViewPat ty expr pat)
         ; ty' <- zonkTcTypeToTypeX env ty
         ; return (env', ViewPat ty' expr' pat') }
 
-zonk_pat env (ListPat (ListPatTc ty Nothing) pats)
+zonk_pat env (ListPat ty pats)
   = do  { ty' <- zonkTcTypeToTypeX env ty
         ; (env', pats') <- zonkPats env pats
-        ; return (env', ListPat (ListPatTc ty' Nothing) pats') }
-
-zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats)
-  = do  { (env', wit') <- zonkSyntaxExpr env wit
-        ; ty2' <- zonkTcTypeToTypeX env' ty2
-        ; ty' <- zonkTcTypeToTypeX env' ty
-        ; (env'', pats') <- zonkPats env' pats
-        ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) pats') }
+        ; return (env', ListPat ty' pats') }
 
 zonk_pat env (TuplePat tys pats boxed)
   = do  { tys' <- mapM (zonkTcTypeToTypeX env) tys
@@ -1466,13 +1459,16 @@ zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2)
         ; ty' <- zonkTcTypeToTypeX env2 ty
         ; return (extendIdZonkEnv env2 n',
                   NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') }
-
-zonk_pat env (XPat (CoPat co_fn pat ty))
-  = do { (env', co_fn') <- zonkCoFn env co_fn
+zonk_pat env (XPat ext) = case ext of
+  { ExpansionPat orig pat->
+    do { (env, pat') <- zonk_pat env pat
+       ; return $ (env, XPat $ ExpansionPat orig pat') }
+  ; CoPat co_fn pat ty ->
+    do { (env', co_fn') <- zonkCoFn env co_fn
        ; (env'', pat') <- zonkPat env' (noLocA pat)
        ; ty' <- zonkTcTypeToTypeX env'' ty
        ; return (env'', XPat $ CoPat co_fn' (unLoc pat') ty')
-       }
+       }}
 
 zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)