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.

9 files changed, 96 insertions, 70 deletions

diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 5156bb0aa1..ad103ca7c8 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -532,9 +532,13 @@ unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
 
 nlConWildPat :: DataCon -> LPat GhcPs
 -- The pattern (K {})
-nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
-                                   (RecCon (HsRecFields { rec_flds = []
-                                                        , rec_dotdot = Nothing })))
+nlConWildPat con = noLoc $ ConPat
+  { pat_con_ext = noExtField
+  , pat_con = noLoc $ getRdrName con
+  , pat_args = RecCon $ HsRecFields
+      { rec_flds = []
+      , rec_dotdot = Nothing }
+  }
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index 94e90acd24..69c5e67197 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -81,9 +81,9 @@ Note that
 ************************************************************************
 -}
 
-tcProc :: InPat GhcRn -> LHsCmdTop GhcRn        -- proc pat -> expr
+tcProc :: LPat GhcRn -> LHsCmdTop GhcRn         -- proc pat -> expr
        -> ExpRhoType                            -- Expected type of whole proc expression
-       -> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion)
+       -> TcM (LPat GhcTc, LHsCmdTop GhcTcId, TcCoercion)
 
 tcProc pat cmd exp_ty
   = newArrowScope $
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index a8a8d027f0..44fd594849 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -506,8 +506,8 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
       tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds
 
 recursivePatSynErr ::
-     OutputableBndrId p =>
-     SrcSpan -- ^ The location of the first pattern synonym binding
+     (OutputableBndrId p, CollectPass (GhcPass p))
+  => SrcSpan -- ^ The location of the first pattern synonym binding
              --   (for error reporting)
   -> LHsBinds (GhcPass p)
   -> TcM a
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 2ae1f1cfb9..0456677cc7 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -521,7 +521,7 @@ tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside
 
 ------------------------
 -- Data constructors
-tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside
+tc_pat penv (ConPat NoExtField con arg_pats) pat_ty thing_inside
   = tcConPat penv con pat_ty arg_pats thing_inside
 
 ------------------------
@@ -872,12 +872,15 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty
                     -- (see Note [Arrows and patterns])
                     (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys'
                                                   arg_pats penv thing_inside
-                  ; let res_pat = ConPatOut { pat_con = header,
-                                              pat_tvs = [], pat_dicts = [],
-                                              pat_binds = emptyTcEvBinds,
-                                              pat_args = arg_pats',
-                                              pat_arg_tys = ctxt_res_tys,
-                                              pat_wrap = idHsWrapper }
+                  ; let res_pat = ConPat { pat_con = header
+                                         , pat_args = arg_pats'
+                                         , pat_con_ext = ConPatTc
+                                           { cpt_tvs = [], cpt_dicts = []
+                                           , cpt_binds = emptyTcEvBinds
+                                           , cpt_arg_tys = ctxt_res_tys
+                                           , cpt_wrap = idHsWrapper
+                                           }
+                                         }
 
                   ; return (mkHsWrapPat wrap res_pat pat_ty, res) }
 
@@ -906,13 +909,17 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty
              <- checkConstraints skol_info ex_tvs' given $
                 tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside
 
-        ; let res_pat = ConPatOut { pat_con   = header,
-                                    pat_tvs   = ex_tvs',
-                                    pat_dicts = given,
-                                    pat_binds = ev_binds,
-                                    pat_args  = arg_pats',
-                                    pat_arg_tys = ctxt_res_tys,
-                                    pat_wrap  = idHsWrapper }
+        ; let res_pat = ConPat
+                { pat_con   = header
+                , pat_args  = arg_pats'
+                , pat_con_ext = ConPatTc
+                  { cpt_tvs   = ex_tvs'
+                  , cpt_dicts = given
+                  , cpt_binds = ev_binds
+                  , cpt_arg_tys = ctxt_res_tys
+                  , cpt_wrap  = idHsWrapper
+                  }
+                }
         ; return (mkHsWrapPat wrap res_pat pat_ty, res)
         } }
 
@@ -957,13 +964,16 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
                 tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside
 
         ; traceTc "checkConstraints }" (ppr ev_binds)
-        ; let res_pat = ConPatOut { pat_con   = L con_span $ PatSynCon pat_syn,
-                                    pat_tvs   = ex_tvs',
-                                    pat_dicts = prov_dicts',
-                                    pat_binds = ev_binds,
-                                    pat_args  = arg_pats',
-                                    pat_arg_tys = mkTyVarTys univ_tvs',
-                                    pat_wrap  = req_wrap }
+        ; let res_pat = ConPat { pat_con   = L con_span $ PatSynCon pat_syn
+                               , pat_args  = arg_pats'
+                               , pat_con_ext = ConPatTc
+                                 { cpt_tvs   = ex_tvs'
+                                 , cpt_dicts = prov_dicts'
+                                 , cpt_binds = ev_binds
+                                 , cpt_arg_tys = mkTyVarTys univ_tvs'
+                                 , cpt_wrap  = req_wrap
+                                 }
+                               }
         ; pat_ty <- readExpType pat_ty
         ; return (mkHsWrapPat wrap res_pat pat_ty, res) }
 
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 07d1453a5c..e69990cb63 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -2178,9 +2178,9 @@ tcDefaultAssocDecl fam_tc
            , text "pats"    <+> ppr pats
            , text "rhs_ty"  <+> ppr rhs_ty
            ])
-       ; pat_tvs <- zipWithM (extract_tv ppr_eqn) pats pats_vis
-       ; check_all_distinct_tvs ppr_eqn $ zip pat_tvs pats_vis
-       ; let subst = zipTvSubst pat_tvs (mkTyVarTys fam_tvs)
+       ; cpt_tvs <- zipWithM (extract_tv ppr_eqn) pats pats_vis
+       ; check_all_distinct_tvs ppr_eqn $ zip cpt_tvs pats_vis
+       ; let subst = zipTvSubst cpt_tvs (mkTyVarTys fam_tvs)
        ; pure $ Just (substTyUnchecked subst rhs_ty, loc)
            -- We also perform other checks for well-formedness and validity
            -- later, in checkValidClass
@@ -2217,8 +2217,8 @@ tcDefaultAssocDecl fam_tc
                             -- visibilities (the latter are only used for error
                             -- message purposes)
       -> TcM ()
-    check_all_distinct_tvs ppr_eqn pat_tvs_vis =
-      let dups = findDupsEq ((==) `on` fst) pat_tvs_vis in
+    check_all_distinct_tvs ppr_eqn cpt_tvs_vis =
+      let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in
       traverse_
         (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $
                pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 797ff2f594..37ba4e3329 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -940,7 +940,7 @@ tcPatToExpr name args pat = go pat
     go (L loc p) = L loc <$> go1 p
 
     go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn)
-    go1 (ConPatIn con info)
+    go1 (ConPat NoExtField con info)
       = case info of
           PrefixCon ps  -> mkPrefixConExpr con ps
           InfixCon l r  -> mkPrefixConExpr con [l,r]
@@ -973,8 +973,6 @@ tcPatToExpr name args pat = go pat
                                     = return $ unLoc $ foldl' nlHsApp (noLoc neg)
                                                        [noLoc (HsOverLit noExtField n)]
         | otherwise                 = return $ HsOverLit noExtField n
-    go1 (ConPatOut{})               = panic "ConPatOut in output of renamer"
-    go1 (CoPat{})                   = panic "CoPat in output of renamer"
     go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
                                     = go1 pat
     go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"
@@ -1124,10 +1122,11 @@ tcCollectEx pat = go pat
     go1 (TuplePat _ ps _)  = mergeMany . map go $ ps
     go1 (SumPat _ p _ _)   = go p
     go1 (ViewPat _ _ p)    = go p
-    go1 con@ConPatOut{}    = merge (pat_tvs con, pat_dicts con) $
+    go1 con@ConPat{ pat_con_ext = con' }
+                           = merge (cpt_tvs con', cpt_dicts con') $
                               goConDetails $ pat_args con
     go1 (SigPat _ p _)     = go p
-    go1 (CoPat _ _ p _)    = go1 p
+    go1 (XPat (CoPat _ 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/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index d12e7efce4..5ee3620db1 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -895,7 +895,7 @@ mkOneRecordSelector all_cons idDetails fl
     mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)
                                  [L loc (mk_sel_pat con)]
                                  (L loc (HsVar noExtField (L loc field_var)))
-    mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
+    mk_sel_pat con = ConPat NoExtField (L loc (getName con)) (RecCon rec_fields)
     rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
     rec_field  = noLoc (HsRecField
                         { hsRecFieldLbl
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 00f11c09ae..09caf5fefa 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -114,14 +114,16 @@ hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = 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
-hsPatType (ConPatOut { pat_con = lcon
-                     , pat_arg_tys = tys })
+hsPatType (ConPat { pat_con = lcon
+                  , pat_con_ext = ConPatTc
+                    { cpt_arg_tys = tys
+                    }
+                  })
                                         = conLikeResTy (unLoc lcon) tys
 hsPatType (SigPat ty _ _)               = ty
 hsPatType (NPat ty _ _ _)               = ty
 hsPatType (NPlusKPat ty _ _ _ _ _)      = ty
-hsPatType (CoPat _ _ _ ty)              = ty
-hsPatType ConPatIn{}                    = panic "hsPatType: ConPatIn"
+hsPatType (XPat (CoPat _ _ ty))         = ty
 hsPatType SplicePat{}                   = panic "hsPatType: SplicePat"
 
 hsLitType :: HsLit (GhcPass p) -> TcType
@@ -1296,7 +1298,7 @@ mapIPNameTc f (Right x) = do r <- f x
 ************************************************************************
 -}
 
-zonkPat :: ZonkEnv -> OutPat GhcTcId -> TcM (ZonkEnv, OutPat GhcTc)
+zonkPat :: ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
 -- Extend the environment as we go, because it's possible for one
 -- pattern to bind something that is used in another (inside or
 -- to the right)
@@ -1358,13 +1360,16 @@ zonk_pat env (SumPat tys pat alt arity )
         ; (env', pat') <- zonkPat env pat
         ; return (env', SumPat tys' pat' alt arity) }
 
-zonk_pat env p@(ConPatOut { pat_arg_tys = tys
-                          , pat_tvs = tyvars
-                          , pat_dicts = evs
-                          , pat_binds = binds
-                          , pat_args = args
-                          , pat_wrap = wrapper
-                          , pat_con = L _ con })
+zonk_pat env p@(ConPat { pat_con = L _ con
+                       , pat_args = args
+                       , pat_con_ext = p'@(ConPatTc
+                         { cpt_tvs = tyvars
+                         , cpt_dicts = evs
+                         , cpt_binds = binds
+                         , cpt_wrap = wrapper
+                         , cpt_arg_tys = tys
+                         })
+                       })
   = ASSERT( all isImmutableTyVar tyvars )
     do  { new_tys <- mapM (zonkTcTypeToTypeX env) tys
 
@@ -1384,12 +1389,19 @@ zonk_pat env p@(ConPatOut { pat_arg_tys = tys
         ; (env2, new_binds) <- zonkTcEvBinds env1 binds
         ; (env3, new_wrapper) <- zonkCoFn env2 wrapper
         ; (env', new_args) <- zonkConStuff env3 args
-        ; return (env', p { pat_arg_tys = new_tys,
-                            pat_tvs = new_tyvars,
-                            pat_dicts = new_evs,
-                            pat_binds = new_binds,
-                            pat_args = new_args,
-                            pat_wrap = new_wrapper}) }
+        ; pure ( env'
+               , p
+                 { pat_args = new_args
+                 , pat_con_ext = p'
+                   { cpt_arg_tys = new_tys
+                   , cpt_tvs = new_tyvars
+                   , cpt_dicts = new_evs
+                   , cpt_binds = new_binds
+                   , cpt_wrap = new_wrapper
+                   }
+                 }
+               )
+        }
   where
     doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p
 
@@ -1420,19 +1432,20 @@ zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2)
         ; return (extendIdZonkEnv env2 n',
                   NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') }
 
-zonk_pat env (CoPat x co_fn pat ty)
+zonk_pat env (XPat (CoPat co_fn pat ty))
   = do { (env', co_fn') <- zonkCoFn env co_fn
        ; (env'', pat') <- zonkPat env' (noLoc pat)
        ; ty' <- zonkTcTypeToTypeX env'' ty
-       ; return (env'', CoPat x co_fn' (unLoc pat') ty') }
+       ; return (env'', XPat $ CoPat co_fn' (unLoc pat') ty')
+       }
 
 zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
 
 ---------------------------
 zonkConStuff :: ZonkEnv
-             -> HsConDetails (OutPat GhcTcId) (HsRecFields id (OutPat GhcTcId))
+             -> HsConDetails (LPat GhcTc) (HsRecFields id (LPat GhcTc))
              -> TcM (ZonkEnv,
-                    HsConDetails (OutPat GhcTc) (HsRecFields id (OutPat GhcTc)))
+                    HsConDetails (LPat GhcTc) (HsRecFields id (LPat GhcTc)))
 zonkConStuff env (PrefixCon pats)
   = do  { (env', pats') <- zonkPats env pats
         ; return (env', PrefixCon pats') }
@@ -1451,7 +1464,7 @@ zonkConStuff env (RecCon (HsRecFields rpats dd))
         -- Field selectors have declared types; hence no zonking
 
 ---------------------------
-zonkPats :: ZonkEnv -> [OutPat GhcTcId] -> TcM (ZonkEnv, [OutPat GhcTc])
+zonkPats :: ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc])
 zonkPats env []         = return (env, [])
 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
                              ; (env', pats') <- zonkPats env1 pats
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
index 6e44a6c399..c72d4cd357 100644
--- a/compiler/GHC/Tc/Validity.hs
+++ b/compiler/GHC/Tc/Validity.hs
@@ -2155,8 +2155,8 @@ checkFamPatBinders fam_tc qtvs pats rhs
               , ppr (mkTyConApp fam_tc pats)
               , text "qtvs:" <+> ppr qtvs
               , text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs)
-              , text "pat_tvs:" <+> ppr pat_tvs
-              , text "inj_pat_tvs:" <+> ppr inj_pat_tvs ]
+              , text "cpt_tvs:" <+> ppr cpt_tvs
+              , text "inj_cpt_tvs:" <+> ppr inj_cpt_tvs ]
 
          -- Check for implicitly-bound tyvars, mentioned on the
          -- RHS but not bound on the LHS
@@ -2176,23 +2176,23 @@ checkFamPatBinders fam_tc qtvs pats rhs
                             (text "used in")
        }
   where
-    pat_tvs     = tyCoVarsOfTypes pats
-    inj_pat_tvs = fvVarSet $ injectiveVarsOfTypes False pats
+    cpt_tvs     = tyCoVarsOfTypes pats
+    inj_cpt_tvs = fvVarSet $ injectiveVarsOfTypes False pats
       -- The type variables that are in injective positions.
       -- See Note [Dodgy binding sites in type family instances]
       -- NB: The False above is irrelevant, as we never have type families in
       -- patterns.
       --
       -- NB: It's OK to use the nondeterministic `fvVarSet` function here,
-      -- since the order of `inj_pat_tvs` is never revealed in an error
+      -- since the order of `inj_cpt_tvs` is never revealed in an error
       -- message.
     rhs_fvs     = tyCoFVsOfType rhs
-    used_tvs    = pat_tvs `unionVarSet` fvVarSet rhs_fvs
+    used_tvs    = cpt_tvs `unionVarSet` fvVarSet rhs_fvs
     bad_qtvs    = filterOut (`elemVarSet` used_tvs) qtvs
                   -- Bound but not used at all
-    bad_rhs_tvs = filterOut (`elemVarSet` inj_pat_tvs) (fvVarList rhs_fvs)
+    bad_rhs_tvs = filterOut (`elemVarSet` inj_cpt_tvs) (fvVarList rhs_fvs)
                   -- Used on RHS but not bound on LHS
-    dodgy_tvs   = pat_tvs `minusVarSet` inj_pat_tvs
+    dodgy_tvs   = cpt_tvs `minusVarSet` inj_cpt_tvs
 
     check_tvs tvs what what2
       = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $