Trees That Grow refactor for `ConPat` and `CoPat`

- `ConPat{In,Out}` -> `ConPat`

- `CoPat` -> `XPat (CoPat ..)`

Note that `GHC.HS.*` still uses `HsWrap`, but only when `p ~ GhcTc`.
After this change, moving the type family instances out of `GHC.HS.*` is
sufficient to break the cycle.

Add XCollectPat class to decide how binders are collected from XXPat based on the pass.

Previously we did this with IsPass, but that doesn't work for Haddock's
DocNameI, and the constraint doesn't express what actual distinction is being
made. Perhaps a class for collecting binders more generally is in order, but we
haven't attempted this yet.

Pure refactor of code around ConPat

 - InPat/OutPat synonyms removed

 - rename several identifiers

 - redundant constraints removed

 - move extension field in ConPat to be first

 - make ConPat use record syntax more consistently

Fix T6145 (ConPatIn became ConPat)

Add comments from SPJ.

Add comment about haddock's use of CollectPass.

Updates haddock submodule.

3 files changed, 319 insertions, 179 deletions

diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 0d67899b4c..db7a46805c 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -358,6 +358,9 @@ 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 (DataIdLR p p, Data body) => Data (HsRecFields p body)
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 2b5c871ab1..c92967db81 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -10,6 +10,7 @@
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveFoldable #-}
 {-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
@@ -23,8 +24,11 @@
 {-# LANGUAGE LambdaCase #-}
 
 module GHC.Hs.Pat (
-        Pat(..), InPat, OutPat, LPat,
+        Pat(..), LPat,
+        ConPatTc (..),
+        CoPat (..),
         ListPatTc(..),
+        ConLikeP,
 
         HsConPatDetails, hsConPatArgs,
         HsRecFields(..), HsRecField'(..), LHsRecField',
@@ -59,7 +63,6 @@ import GHC.Tc.Types.Evidence
 import GHC.Types.Basic
 -- others:
 import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} )
-import GHC.Driver.Session ( gopt, GeneralFlag(Opt_PrintTypecheckerElaboration) )
 import GHC.Builtin.Types
 import GHC.Types.Var
 import GHC.Types.Name.Reader ( RdrName )
@@ -71,12 +74,10 @@ import GHC.Core.Type
 import GHC.Types.SrcLoc
 import Bag -- collect ev vars from pats
 import Maybes
+import GHC.Types.Name (Name)
 -- libraries:
 import Data.Data hiding (TyCon,Fixity)
 
-type InPat p  = LPat p        -- No 'Out' constructors
-type OutPat p = LPat p        -- No 'In' constructors
-
 type LPat p = XRec p Pat
 
 -- | Pattern
@@ -173,30 +174,12 @@ data Pat p
     -- For details on above see note [Api annotations] in GHC.Parser.Annotation
 
         ------------ Constructor patterns ---------------
-  | ConPatIn    (Located (IdP p))
-                (HsConPatDetails p)
-    -- ^ Constructor Pattern In
-
-  | ConPatOut {
-        pat_con     :: Located ConLike,
-        pat_arg_tys :: [Type],          -- The universal arg types, 1-1 with the universal
-                                        -- tyvars of the constructor/pattern synonym
-                                        --   Use (conLikeResTy pat_con pat_arg_tys) to get
-                                        --   the type of the pattern
-
-        pat_tvs   :: [TyVar],           -- Existentially bound type variables
-                                        -- in correctly-scoped order e.g. [k:*, x:k]
-        pat_dicts :: [EvVar],           -- Ditto *coercion variables* and *dictionaries*
-                                        -- One reason for putting coercion variable here, I think,
-                                        --      is to ensure their kinds are zonked
-
-        pat_binds :: TcEvBinds,         -- Bindings involving those dictionaries
-        pat_args  :: HsConPatDetails p,
-        pat_wrap  :: HsWrapper          -- Extra wrapper to pass to the matcher
-                                        -- Only relevant for pattern-synonyms;
-                                        --   ignored for data cons
+  | ConPat {
+        pat_con_ext :: XConPat p,
+        pat_con     :: Located (ConLikeP p),
+        pat_args    :: HsConPatDetails p
     }
-    -- ^ Constructor Pattern Out
+    -- ^ Constructor Pattern
 
         ------------ View patterns ---------------
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'
@@ -262,17 +245,6 @@ data Pat p
 
     -- ^ Pattern with a type signature
 
-        ------------ Pattern coercions (translation only) ---------------
-  | CoPat       (XCoPat p)
-                HsWrapper           -- Coercion Pattern
-                                    -- If co :: t1 ~ t2, p :: t2,
-                                    -- then (CoPat co p) :: t1
-                (Pat p)             -- Why not LPat?  Ans: existing locn will do
-                Type                -- Type of whole pattern, t1
-        -- During desugaring a (CoPat co pat) turns into a cast with 'co' on
-        -- the scrutinee, followed by a match on 'pat'
-    -- ^ Coercion Pattern
-
   -- | Trees that Grow extension point for new constructors
   | XPat
       !(XXPat p)
@@ -306,6 +278,10 @@ type instance XTuplePat GhcPs = NoExtField
 type instance XTuplePat GhcRn = NoExtField
 type instance XTuplePat GhcTc = [Type]
 
+type instance XConPat GhcPs = NoExtField
+type instance XConPat GhcRn = NoExtField
+type instance XConPat GhcTc = ConPatTc
+
 type instance XSumPat GhcPs = NoExtField
 type instance XSumPat GhcRn = NoExtField
 type instance XSumPat GhcTc = [Type]
@@ -329,9 +305,16 @@ type instance XSigPat GhcPs = NoExtField
 type instance XSigPat GhcRn = NoExtField
 type instance XSigPat GhcTc = Type
 
-type instance XCoPat  (GhcPass _) = NoExtField
+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   (GhcPass _) = NoExtCon
+type family ConLikeP x
+
+type instance ConLikeP GhcPs = RdrName -- IdP GhcPs
+type instance ConLikeP GhcRn = Name -- IdP GhcRn
+type instance ConLikeP GhcTc = ConLike
 
 -- ---------------------------------------------------------------------
 
@@ -344,6 +327,52 @@ hsConPatArgs (PrefixCon ps)   = ps
 hsConPatArgs (RecCon fs)      = map (hsRecFieldArg . unLoc) (rec_flds fs)
 hsConPatArgs (InfixCon p1 p2) = [p1,p2]
 
+-- | 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
+  = ConPatTc
+    { -- | The universal arg types  1-1 with the universal
+      -- tyvars of the constructor/pattern synonym
+      -- Use (conLikeResTy pat_con cpt_arg_tys) to get
+      -- the type of the pattern
+      cpt_arg_tys :: [Type]
+
+    , -- | Existentially bound type variables
+      -- in correctly-scoped order e.g. [k:*  x:k]
+      cpt_tvs   :: [TyVar]
+
+    , -- | Ditto *coercion variables* and *dictionaries*
+      -- One reason for putting coercion variable here  I think
+      --      is to ensure their kinds are zonked
+      cpt_dicts :: [EvVar]
+
+    , -- | Bindings involving those dictionaries
+      cpt_binds :: TcEvBinds
+
+    , -- ^ Extra wrapper to pass to the matcher
+      -- Only relevant for pattern-synonyms;
+      --   ignored for data cons
+      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
+    }
+
 -- | Haskell Record Fields
 --
 -- HsRecFields is used only for patterns and expressions (not data type
@@ -498,16 +527,23 @@ pprParendLPat :: (OutputableBndrId p)
               => PprPrec -> LPat (GhcPass p) -> SDoc
 pprParendLPat p = pprParendPat p . unLoc
 
-pprParendPat :: (OutputableBndrId p)
-             => PprPrec -> Pat (GhcPass p) -> SDoc
-pprParendPat p pat = sdocOption sdocPrintTypecheckerElaboration $ \print_tc_elab ->
-                     if need_parens print_tc_elab pat
-                     then parens (pprPat pat)
-                     else  pprPat pat
+pprParendPat :: forall p. OutputableBndrId p
+             => PprPrec
+             -> Pat (GhcPass p)
+             -> SDoc
+pprParendPat p pat = sdocOption sdocPrintTypecheckerElaboration $ \ print_tc_elab ->
+    if need_parens print_tc_elab pat
+    then parens (pprPat pat)
+    else pprPat pat
   where
     need_parens print_tc_elab pat
-      | CoPat {} <- pat = print_tc_elab
-      | otherwise       = patNeedsParens p pat
+      | GhcTc <- ghcPass @p
+      , XPat ext <- pat
+      , CoPat {} <- ext
+      = print_tc_elab
+
+      | otherwise
+      = patNeedsParens p pat
       -- For a CoPat we need parens if we are going to show it, which
       -- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper)
       -- But otherwise the CoPat is discarded, so it
@@ -527,12 +563,6 @@ pprPat (NPat _ l Nothing  _)    = ppr l
 pprPat (NPat _ l (Just _) _)    = char '-' <> ppr l
 pprPat (NPlusKPat _ n k _ _ _)  = hcat [ppr n, char '+', ppr k]
 pprPat (SplicePat _ splice)     = pprSplice splice
-pprPat (CoPat _ co pat _)       = pprIfTc @p $
-                                  sdocWithDynFlags $ \ dflags ->
-                                  if gopt Opt_PrintTypecheckerElaboration dflags
-                                  then hang (text "CoPat" <+> parens (ppr co))
-                                          2 (pprParendPat appPrec pat)
-                                  else pprPat pat
 pprPat (SigPat _ pat ty)        = ppr pat <+> dcolon <+> ppr_ty
   where ppr_ty = case ghcPass @p of
                    GhcPs -> ppr ty
@@ -548,22 +578,37 @@ pprPat (TuplePat _ pats bx)
   | otherwise
   = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)
 pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity)
-pprPat (ConPatIn con details)   = pprUserCon (unLoc con) details
-pprPat (ConPatOut { pat_con = con
-                  , pat_tvs = tvs
-                  , pat_dicts = dicts
-                  , pat_binds = binds
-                  , pat_args = details })
-  = sdocOption sdocPrintTypecheckerElaboration $ \case
-      False -> pprUserCon (unLoc con) details
-      True  -> -- Tiresome; in GHC.Tc.Gen.Bind.tcRhs we print out a
-               -- typechecked Pat in an error message,
-               -- and we want to make sure it prints nicely
-               ppr con
-                  <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
-                                 , pprIfTc @p $ ppr binds ])
-                  <+> pprConArgs details
-
+pprPat (ConPat { pat_con = con
+               , pat_args = details
+               , pat_con_ext = ext
+               }
+       )
+  = case ghcPass @p of
+      GhcPs -> pprUserCon (unLoc con) details
+      GhcRn -> pprUserCon (unLoc con) details
+      GhcTc -> sdocOption sdocPrintTypecheckerElaboration $ \case
+        False -> pprUserCon (unLoc con) details
+        True  ->
+          -- Tiresome; in TcBinds.tcRhs we print out a typechecked Pat in an
+          -- error message, and we want to make sure it prints nicely
+          ppr con
+            <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
+                           , ppr binds ])
+            <+> pprConArgs details
+        where ConPatTc { cpt_tvs = tvs
+                       , cpt_dicts = dicts
+                       , cpt_binds = binds
+                       } = ext
+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
 
 pprUserCon :: (OutputableBndr con, OutputableBndrId p)
            => con -> HsConPatDetails (GhcPass p) -> SDoc
@@ -602,21 +647,24 @@ instance (Outputable p, Outputable arg)
 -}
 
 mkPrefixConPat :: DataCon ->
-                  [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p)
+                  [LPat GhcTc] -> [Type] -> LPat GhcTc
 -- Make a vanilla Prefix constructor pattern
 mkPrefixConPat dc pats tys
-  = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc)
-                      , pat_tvs = []
-                      , pat_dicts = []
-                      , pat_binds = emptyTcEvBinds
-                      , pat_args = PrefixCon pats
-                      , pat_arg_tys = tys
-                      , pat_wrap = idHsWrapper }
-
-mkNilPat :: Type -> OutPat (GhcPass p)
+  = noLoc $ ConPat { pat_con = noLoc (RealDataCon dc)
+                   , pat_args = PrefixCon pats
+                   , pat_con_ext = ConPatTc
+                     { cpt_tvs = []
+                     , cpt_dicts = []
+                     , cpt_binds = emptyTcEvBinds
+                     , cpt_arg_tys = tys
+                     , cpt_wrap = idHsWrapper
+                     }
+                   }
+
+mkNilPat :: Type -> LPat GhcTc
 mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]
 
-mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p)
+mkCharLitPat :: SourceText -> Char -> LPat GhcTc
 mkCharLitPat src c = mkPrefixConPat charDataCon
                           [noLoc $ LitPat noExtField (HsCharPrim src c)] []
 
@@ -684,7 +732,7 @@ looksLazyPat (VarPat {})   = False
 looksLazyPat (WildPat {})  = False
 looksLazyPat _             = True
 
-isIrrefutableHsPat :: (OutputableBndrId p) => LPat (GhcPass p) -> Bool
+isIrrefutableHsPat :: forall p. (OutputableBndrId p) => LPat (GhcPass p) -> Bool
 -- (isIrrefutableHsPat p) is true if matching against p cannot fail,
 -- in the sense of falling through to the next pattern.
 --      (NB: this is not quite the same as the (silly) defn
@@ -700,13 +748,14 @@ isIrrefutableHsPat :: (OutputableBndrId p) => LPat (GhcPass p) -> Bool
 isIrrefutableHsPat
   = goL
   where
+    goL :: LPat (GhcPass p) -> Bool
     goL = go . unLoc
 
+    go :: Pat (GhcPass p) -> Bool
     go (WildPat {})        = True
     go (VarPat {})         = True
     go (LazyPat {})        = True
     go (BangPat _ pat)     = goL pat
-    go (CoPat _ _ pat _)   = go  pat
     go (ParPat _ pat)      = goL pat
     go (AsPat _ _ pat)     = goL pat
     go (ViewPat _ _ pat)   = goL pat
@@ -716,18 +765,19 @@ isIrrefutableHsPat
                     -- See Note [Unboxed sum patterns aren't irrefutable]
     go (ListPat {})        = False
 
-    go (ConPatIn {})       = False     -- Conservative
-    go (ConPatOut
-        { pat_con  = L _ (RealDataCon con)
+    go (ConPat
+        { pat_con  = con
         , pat_args = details })
-                           =
-      isJust (tyConSingleDataCon_maybe (dataConTyCon con))
-      -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because
-      -- the latter is false of existentials. See #4439
-      && all goL (hsConPatArgs details)
-    go (ConPatOut
-        { pat_con = L _ (PatSynCon _pat) })
-                           = False -- Conservative
+                           = case ghcPass @p of
+       GhcPs -> False -- Conservative
+       GhcRn -> False -- Conservative
+       GhcTc -> case con of
+         L _ (PatSynCon _pat)  -> False -- Conservative
+         L _ (RealDataCon con) ->
+           isJust (tyConSingleDataCon_maybe (dataConTyCon con))
+           -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because
+           -- the latter is false of existentials. See #4439
+           && all goL (hsConPatArgs details)
     go (LitPat {})         = False
     go (NPat {})           = False
     go (NPlusKPat {})      = False
@@ -736,6 +786,14 @@ isIrrefutableHsPat
     -- since we cannot know until the splice is evaluated.
     go (SplicePat {})      = False
 
+    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
+
 -- | Is the pattern any of combination of:
 --
 -- - (pat)
@@ -777,16 +835,21 @@ is the only thing that could possibly be matched!
 
 -- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs
 -- parentheses under precedence @p@.
-patNeedsParens :: PprPrec -> Pat p -> Bool
+patNeedsParens :: forall p. IsPass p => PprPrec -> Pat (GhcPass p) -> Bool
 patNeedsParens p = go
   where
+    go :: Pat (GhcPass p) -> Bool
     go (NPlusKPat {})    = p > opPrec
     go (SplicePat {})    = False
-    go (ConPatIn _ ds)   = conPatNeedsParens p ds
-    go cp@(ConPatOut {}) = conPatNeedsParens p (pat_args cp)
+    go (ConPat { pat_args = ds})
+                         = conPatNeedsParens p ds
     go (SigPat {})       = p >= sigPrec
     go (ViewPat {})      = True
-    go (CoPat _ _ p _)   = go p
+    go (XPat ext)        = case ghcPass @p of
+      GhcPs -> noExtCon ext
+      GhcRn -> noExtCon ext
+      GhcTc -> go inner
+        where CoPat _ inner _ = ext
     go (WildPat {})      = False
     go (VarPat {})       = False
     go (LazyPat {})      = False
@@ -798,7 +861,6 @@ patNeedsParens p = go
     go (ListPat {})      = False
     go (LitPat _ l)      = hsLitNeedsParens p l
     go (NPat _ lol _ _)  = hsOverLitNeedsParens p (unLoc lol)
-    go (XPat {})         = True -- conservative default
 
 -- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@
 -- needs parentheses under precedence @p@.
@@ -811,7 +873,10 @@ conPatNeedsParens p = go
 
 -- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and
 -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.
-parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
+parenthesizePat :: IsPass p
+                => PprPrec
+                -> LPat (GhcPass p)
+                -> LPat (GhcPass p)
 parenthesizePat p lpat@(L loc pat)
   | patNeedsParens p pat = L loc (ParPat noExtField lpat)
   | otherwise            = lpat
@@ -837,12 +902,16 @@ collectEvVarsPat pat =
     ListPat _ ps     -> unionManyBags $ map collectEvVarsLPat ps
     TuplePat _ ps _  -> unionManyBags $ map collectEvVarsLPat ps
     SumPat _ p _ _   -> collectEvVarsLPat p
-    ConPatOut {pat_dicts = dicts, pat_args  = args}
+    ConPat
+      { pat_args  = args
+      , pat_con_ext = ConPatTc
+        { cpt_dicts = dicts
+        }
+      }
                      -> unionBags (listToBag dicts)
                                    $ unionManyBags
                                    $ map collectEvVarsLPat
                                    $ hsConPatArgs args
     SigPat  _ p _    -> collectEvVarsLPat p
-    CoPat _ _ p _    -> collectEvVarsPat  p
-    ConPatIn _  _    -> panic "foldMapPatBag: ConPatIn"
+    XPat (CoPat _ p _) -> collectEvVarsPat  p
     _other_pat       -> emptyBag
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 0b3300719e..75ef5b06bf 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -24,6 +24,9 @@ just attach noSrcSpan to everything.
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 
@@ -89,6 +92,7 @@ module GHC.Hs.Utils(
   collectPatBinders, collectPatsBinders,
   collectLStmtsBinders, collectStmtsBinders,
   collectLStmtBinders, collectStmtBinders,
+  CollectPass(..),
 
   hsLTyClDeclBinders, hsTyClForeignBinders,
   hsPatSynSelectors, getPatSynBinds,
@@ -135,6 +139,7 @@ import GHC.Settings.Constants
 import Data.Either
 import Data.Function
 import Data.List
+import Data.Proxy
 
 {-
 ************************************************************************
@@ -196,8 +201,11 @@ mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct)
 mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
 mkHsAppTypes = foldl' mkHsAppType
 
-mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
-  [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
+mkHsLam :: IsPass p
+        => (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField)
+        => [LPat (GhcPass p)]
+        -> LHsExpr (GhcPass p)
+        -> LHsExpr (GhcPass p)
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))
   where
     matches = mkMatchGroup Generated
@@ -230,7 +238,7 @@ mkLHsPar le@(L loc e)
   | hsExprNeedsParens appPrec e = L loc (HsPar noExtField le)
   | otherwise                   = le
 
-mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
+mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p)
 mkParPat lp@(L loc p)
   | patNeedsParens appPrec p = L loc (ParPat noExtField lp)
   | otherwise                = lp
@@ -435,25 +443,42 @@ nlConVarPatName :: Name -> [Name] -> LPat GhcRn
 nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
 
 nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs
-nlInfixConPat con l r = noLoc (ConPatIn (noLoc con)
-                              (InfixCon (parenthesizePat opPrec l)
-                                        (parenthesizePat opPrec r)))
+nlInfixConPat con l r = noLoc $ ConPat
+  { pat_con = noLoc con
+  , pat_args = InfixCon (parenthesizePat opPrec l)
+                        (parenthesizePat opPrec r)
+  , pat_con_ext = noExtField
+  }
 
 nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
-nlConPat con pats =
-  noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))
+nlConPat con pats = noLoc $ ConPat
+  { pat_con_ext = noExtField
+  , pat_con = noLoc con
+  , pat_args = PrefixCon (map (parenthesizePat appPrec) pats)
+  }
 
 nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
-nlConPatName con pats =
-  noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))
-
-nlNullaryConPat :: IdP (GhcPass p) -> LPat (GhcPass p)
-nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
+nlConPatName con pats = noLoc $ ConPat
+  { pat_con_ext = noExtField
+  , pat_con = noLoc con
+  , pat_args = PrefixCon (map (parenthesizePat appPrec) pats)
+  }
+
+nlNullaryConPat :: RdrName -> LPat GhcPs
+nlNullaryConPat con = noLoc $ ConPat
+  { pat_con_ext = noExtField
+  , pat_con = noLoc con
+  , pat_args = PrefixCon []
+  }
 
 nlWildConPat :: DataCon -> LPat GhcPs
-nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
-                         (PrefixCon (replicate (dataConSourceArity con)
-                                             nlWildPat)))
+nlWildConPat con = noLoc $ ConPat
+  { pat_con_ext = noExtField
+  , pat_con = noLoc $ getRdrName con
+  , pat_args = PrefixCon $
+     replicate (dataConSourceArity con)
+               nlWildPat
+  }
 
 -- | Wildcard pattern - after parsing
 nlWildPat :: LPat GhcPs
@@ -800,11 +825,11 @@ mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
 
 mkHsWrapPat :: HsWrapper -> Pat GhcTc -> Type -> Pat GhcTc
 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
-                       | otherwise           = CoPat noExtField co_fn p ty
+                       | otherwise           = XPat $ CoPat co_fn p ty
 
 mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc
 mkHsWrapPatCo co pat ty | isTcReflCo co = pat
-                        | otherwise    = CoPat noExtField (mkWpCastN co) pat ty
+                        | otherwise     = XPat $ CoPat (mkWpCastN co) pat ty
 
 mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
@@ -879,8 +904,10 @@ mkPrefixFunRhs n = FunRhs { mc_fun = n
                           , mc_strictness = NoSrcStrict }
 
 ------------
-mkMatch :: HsMatchContext (NoGhcTc (GhcPass p))
-        -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p)
+mkMatch :: forall p. IsPass p
+        => HsMatchContext (NoGhcTc (GhcPass p))
+        -> [LPat (GhcPass p)]
+        -> LHsExpr (GhcPass p)
         -> Located (HsLocalBinds (GhcPass p))
         -> LMatch (GhcPass p) (LHsExpr (GhcPass p))
 mkMatch ctxt pats expr lbinds
@@ -889,6 +916,7 @@ mkMatch ctxt pats expr lbinds
                  , m_pats  = map paren pats
                  , m_grhss = GRHSs noExtField (unguardedRHS noSrcSpan expr) lbinds })
   where
+    paren :: Located (Pat (GhcPass p)) -> Located (Pat (GhcPass p))
     paren lp@(L l p)
       | patNeedsParens appPrec p = L l (ParPat noExtField lp)
       | otherwise                = lp
@@ -978,49 +1006,69 @@ isBangedHsBind (PatBind {pat_lhs = pat})
 isBangedHsBind _
   = False
 
-collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR)
+collectLocalBinders :: CollectPass (GhcPass idL)
+                    => HsLocalBindsLR (GhcPass idL) (GhcPass idR)
                     -> [IdP (GhcPass idL)]
 collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds
                                          -- No pattern synonyms here
 collectLocalBinders (HsIPBinds {})      = []
 collectLocalBinders (EmptyLocalBinds _) = []
 
-collectHsIdBinders, collectHsValBinders
-  :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
+collectHsIdBinders :: CollectPass (GhcPass idL)
+                   => HsValBindsLR (GhcPass idL) (GhcPass idR)
+                   -> [IdP (GhcPass idL)]
 -- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively
 collectHsIdBinders  = collect_hs_val_binders True
+
+collectHsValBinders :: CollectPass (GhcPass idL)
+                    => HsValBindsLR (GhcPass idL) (GhcPass idR)
+                    -> [IdP (GhcPass idL)]
 collectHsValBinders = collect_hs_val_binders False
 
-collectHsBindBinders :: XRec pass Pat ~ Located (Pat pass) =>
-                        HsBindLR pass idR -> [IdP pass]
+collectHsBindBinders :: CollectPass p
+                     => HsBindLR p idR
+                     -> [IdP p]
 -- ^ Collect both 'Id's and pattern-synonym binders
 collectHsBindBinders b = collect_bind False b []
 
-collectHsBindsBinders :: LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)]
+collectHsBindsBinders :: CollectPass p
+                      => LHsBindsLR p idR
+                      -> [IdP p]
 collectHsBindsBinders binds = collect_binds False binds []
 
-collectHsBindListBinders :: [LHsBindLR (GhcPass p) idR] -> [IdP (GhcPass p)]
+collectHsBindListBinders :: CollectPass p
+                         => [LHsBindLR p idR]
+                         -> [IdP p]
 -- ^ Same as 'collectHsBindsBinders', but works over a list of bindings
 collectHsBindListBinders = foldr (collect_bind False . unLoc) []
 
-collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR)
+collect_hs_val_binders :: CollectPass (GhcPass idL)
+                       => Bool
+                       -> HsValBindsLR (GhcPass idL) (GhcPass idR)
                        -> [IdP (GhcPass idL)]
 collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds []
 collect_hs_val_binders ps (XValBindsLR (NValBinds binds _))
   = collect_out_binds ps binds
 
-collect_out_binds :: Bool -> [(RecFlag, LHsBinds (GhcPass p))] ->
-                     [IdP (GhcPass p)]
+collect_out_binds :: CollectPass p
+                  => Bool
+                  -> [(RecFlag, LHsBinds p)]
+                  -> [IdP p]
 collect_out_binds ps = foldr (collect_binds ps . snd) []
 
-collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR ->
-                 [IdP (GhcPass p)] -> [IdP (GhcPass p)]
+collect_binds :: CollectPass p
+              => Bool
+              -> LHsBindsLR p idR
+              -> [IdP p]
+              -> [IdP p]
 -- ^ Collect 'Id's, or 'Id's + pattern synonyms, depending on boolean flag
 collect_binds ps binds acc = foldr (collect_bind ps . unLoc) acc binds
 
-collect_bind :: XRec pass Pat ~ Located (Pat pass) =>
-                Bool -> HsBindLR pass idR ->
-                [IdP pass] -> [IdP pass]
+collect_bind :: CollectPass p
+             => Bool
+             -> HsBindLR p idR
+             -> [IdP p]
+             -> [IdP p]
 collect_bind _ (PatBind { pat_lhs = p })           acc = collect_lpat p acc
 collect_bind _ (FunBind { fun_id = L _ f })        acc = f : acc
 collect_bind _ (VarBind { var_id = f })            acc = f : acc
@@ -1044,19 +1092,23 @@ collectMethodBinders binds = foldr (get . unLoc) [] binds
        -- Someone else complains about non-FunBinds
 
 ----------------- Statements --------------------------
-collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body]
+collectLStmtsBinders :: (CollectPass (GhcPass idL))
+                     => [LStmtLR (GhcPass idL) (GhcPass idR) body]
                      -> [IdP (GhcPass idL)]
 collectLStmtsBinders = concatMap collectLStmtBinders
 
-collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body]
+collectStmtsBinders :: (CollectPass (GhcPass idL))
+                    => [StmtLR (GhcPass idL) (GhcPass idR) body]
                     -> [IdP (GhcPass idL)]
 collectStmtsBinders = concatMap collectStmtBinders
 
-collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body
+collectLStmtBinders :: (CollectPass (GhcPass idL))
+                    => LStmtLR (GhcPass idL) (GhcPass idR) body
                     -> [IdP (GhcPass idL)]
 collectLStmtBinders = collectStmtBinders . unLoc
 
-collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body
+collectStmtBinders :: (CollectPass (GhcPass idL))
+                   => StmtLR (GhcPass idL) (GhcPass idR) body
                    -> [IdP (GhcPass idL)]
   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 collectStmtBinders (BindStmt _ pat _)      = collectPatBinders pat
@@ -1071,47 +1123,65 @@ collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args
  where
   collectArgBinders (_, ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat
   collectArgBinders (_, ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat
+  collectArgBinders (_, XApplicativeArg {}) = []
 
 
 ----------------- Patterns --------------------------
-collectPatBinders :: LPat (GhcPass p) -> [IdP (GhcPass p)]
+collectPatBinders :: CollectPass p => LPat p -> [IdP p]
 collectPatBinders pat = collect_lpat pat []
 
-collectPatsBinders :: [LPat (GhcPass p)] -> [IdP (GhcPass p)]
+collectPatsBinders :: CollectPass p => [LPat p] -> [IdP p]
 collectPatsBinders pats = foldr collect_lpat [] pats
 
 -------------
-collect_lpat :: XRec pass Pat ~ Located (Pat pass) =>
-                LPat pass -> [IdP pass] -> [IdP pass]
-collect_lpat p bndrs
-  = go (unLoc p)
-  where
-    go (VarPat _ var)             = unLoc var : bndrs
-    go (WildPat _)                = bndrs
-    go (LazyPat _ pat)            = collect_lpat pat bndrs
-    go (BangPat _ pat)            = collect_lpat pat bndrs
-    go (AsPat _ a pat)            = unLoc a : collect_lpat pat bndrs
-    go (ViewPat _ _ pat)          = collect_lpat pat bndrs
-    go (ParPat _ pat)             = collect_lpat pat bndrs
-
-    go (ListPat _ pats)           = foldr collect_lpat bndrs pats
-    go (TuplePat _ pats _)        = foldr collect_lpat bndrs pats
-    go (SumPat _ pat _ _)         = collect_lpat pat bndrs
-
-    go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)
-    go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)
-        -- See Note [Dictionary binders in ConPatOut]
-    go (LitPat _ _)               = bndrs
-    go (NPat {})                  = bndrs
-    go (NPlusKPat _ n _ _ _ _)    = unLoc n : bndrs
-
-    go (SigPat _ pat _)           = collect_lpat pat bndrs
-
-    go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
-                                  = go pat
-    go (SplicePat _ _)            = bndrs
-    go (CoPat _ _ pat _)          = go pat
-    go (XPat {})                  = bndrs
+collect_lpat :: forall pass. (CollectPass pass)
+             => LPat pass -> [IdP pass] -> [IdP pass]
+collect_lpat p bndrs = collect_pat (unLoc p) bndrs
+
+collect_pat :: forall p. CollectPass p
+            => Pat p
+            -> [IdP p]
+            -> [IdP p]
+collect_pat pat bndrs = case pat of
+  (VarPat _ var)          -> unLoc var : bndrs
+  (WildPat _)             -> bndrs
+  (LazyPat _ pat)         -> collect_lpat pat bndrs
+  (BangPat _ pat)         -> collect_lpat pat bndrs
+  (AsPat _ a pat)         -> unLoc a : collect_lpat pat bndrs
+  (ViewPat _ _ pat)       -> collect_lpat pat bndrs
+  (ParPat _ pat)          -> collect_lpat pat bndrs
+  (ListPat _ pats)        -> foldr collect_lpat bndrs pats
+  (TuplePat _ pats _)     -> foldr collect_lpat bndrs pats
+  (SumPat _ pat _ _)      -> collect_lpat pat bndrs
+  (ConPat {pat_args=ps})  -> foldr collect_lpat bndrs (hsConPatArgs ps)
+  -- See Note [Dictionary binders in ConPatOut]
+  (LitPat _ _)            -> bndrs
+  (NPat {})               -> bndrs
+  (NPlusKPat _ n _ _ _ _) -> unLoc n : bndrs
+  (SigPat _ pat _)        -> collect_lpat pat bndrs
+  (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
+                          -> collect_pat pat bndrs
+  (SplicePat _ _)         -> bndrs
+  (XPat ext)              -> collectXXPat (Proxy @p) ext bndrs
+
+-- | This class specifies how to collect variable identifiers from extension patterns in the given pass.
+-- Consumers of the GHC API that define their own passes should feel free to implement instances in order
+-- to make use of functions which depend on it.
+--
+-- In particular, Haddock already makes use of this, with an instance for its 'DocNameI' pass so that
+-- it can reuse the code in GHC for collecting binders.
+class (XRec p Pat ~ Located (Pat p)) => CollectPass p where
+  collectXXPat :: Proxy p -> XXPat p -> [IdP p] -> [IdP p]
+
+instance CollectPass (GhcPass 'Parsed) where
+  collectXXPat _ ext = noExtCon ext
+
+instance CollectPass (GhcPass 'Renamed) where
+  collectXXPat _ ext = noExtCon ext
+
+instance CollectPass (GhcPass 'Typechecked) where
+  collectXXPat _ (CoPat _ pat _) = collect_pat pat
+
 
 {-
 Note [Dictionary binders in ConPatOut] See also same Note in GHC.HsToCore.Arrows
@@ -1393,10 +1463,8 @@ lPatImplicits = hs_lpat
     hs_pat (TuplePat _ pats _)  = hs_lpats pats
 
     hs_pat (SigPat _ pat _)     = hs_lpat pat
-    hs_pat (CoPat _ _ pat _)    = hs_pat pat
 
-    hs_pat (ConPatIn n ps)           = details n ps
-    hs_pat (ConPatOut {pat_con=con, pat_args=ps}) = details (fmap conLikeName con) ps
+    hs_pat (ConPat {pat_con=con, pat_args=ps}) = details con ps
 
     hs_pat _ = []