[Git][ghc/ghc][wip/ttg-con-pat] Pure refactor of code around ConPat

cgibbard gitlab at gitlab.haskell.org
Wed Apr 8 17:43:33 UTC 2020



cgibbard pushed to branch wip/ttg-con-pat at Glasgow Haskell Compiler / GHC


Commits:
63e007f1 by Cale Gibbard at 2020-04-08T13:40:48-04:00
Pure refactor of code around ConPat

Now that things are working, clean some things up:

 - 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

- - - - -


26 changed files:

- compiler/GHC/Hs/Extension.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Arrows.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/ListComp.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match/Constructor.hs
- compiler/GHC/HsToCore/PmCheck.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Types.hs
- compiler/GHC/ThToHs.hs
- compiler/parser/RdrHsSyn.hs
- compiler/typecheck/TcArrows.hs
- compiler/typecheck/TcBinds.hs
- compiler/typecheck/TcGenDeriv.hs
- compiler/typecheck/TcHsSyn.hs
- compiler/typecheck/TcPat.hs
- compiler/typecheck/TcPatSyn.hs
- compiler/typecheck/TcTyClsDecls.hs
- compiler/typecheck/TcTyDecls.hs
- compiler/typecheck/TcValidity.hs
- utils/haddock


Changes:

=====================================
compiler/GHC/Hs/Extension.hs
=====================================
@@ -662,7 +662,6 @@ type family XListPat   x
 type family XTuplePat  x
 type family XSumPat    x
 type family XConPat    x
-type family XConPatCon x
 type family XViewPat   x
 type family XSplicePat x
 type family XLitPat    x


=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -23,10 +23,11 @@
 {-# LANGUAGE LambdaCase #-}
 
 module GHC.Hs.Pat (
-        Pat(..), InPat, OutPat, LPat,
+        Pat(..), LPat,
         ConPatTc (..),
         CoPat (..),
         ListPatTc(..),
+        ConLikeP,
 
         HsConPatDetails, hsConPatArgs,
         HsRecFields(..), HsRecField'(..), LHsRecField',
@@ -72,12 +73,10 @@ import GHC.Core.Type
 import SrcLoc
 import Bag -- collect ev vars from pats
 import Maybes
+import Name (Name)
 -- libraries:
 import Data.Data hiding (TyCon,Fixity)
 
-type InPat p  = LPat p        -- No 'Out' constructors
-type OutPat p = LPat GhcTc    -- No 'In' constructors
-
 type LPat p = XRec p Pat
 
 -- | Pattern
@@ -175,9 +174,9 @@ data Pat p
 
         ------------ Constructor patterns ---------------
   | ConPat {
-        pat_con   :: Located (XConPatCon p),
-        pat_args  :: HsConPatDetails p,
-        pat_con_ext :: XConPat p
+        pat_con_ext :: XConPat p,
+        pat_con     :: Located (ConLikeP p),
+        pat_args    :: HsConPatDetails p
     }
     -- ^ Constructor Pattern
 
@@ -282,10 +281,6 @@ type instance XConPat GhcPs = NoExtField
 type instance XConPat GhcRn = NoExtField
 type instance XConPat GhcTc = ConPatTc
 
-type instance XConPatCon GhcPs = IdP GhcPs
-type instance XConPatCon GhcRn = IdP GhcRn
-type instance XConPatCon GhcTc = ConLike
-
 type instance XSumPat GhcPs = NoExtField
 type instance XSumPat GhcRn = NoExtField
 type instance XSumPat GhcTc = [Type]
@@ -313,6 +308,11 @@ type instance XXPat GhcPs = NoExtCon
 type instance XXPat GhcRn = NoExtCon
 type instance XXPat GhcTc = CoPat
 
+type family ConLikeP x
+
+type instance ConLikeP GhcPs = RdrName -- IdP GhcPs
+type instance ConLikeP GhcRn = Name -- IdP GhcRn
+type instance ConLikeP GhcTc = ConLike
 
 -- ---------------------------------------------------------------------
 
@@ -329,26 +329,26 @@ data ConPatTc
   = ConPatTc
     { -- | The universal arg types  1-1 with the universal
       -- tyvars of the constructor/pattern synonym
-      -- Use (conLikeResTy pat_con pat_arg_tys) to get
+      -- Use (conLikeResTy pat_con cpt_arg_tys) to get
       -- the type of the pattern
-      pat_arg_tys :: [Type]
+      cpt_arg_tys :: [Type]
 
     , -- | Existentially bound type variables
       -- in correctly-scoped order e.g. [k:*  x:k]
-      pat_tvs   :: [TyVar]
+      cpt_tvs   :: [TyVar]
 
     , -- | Ditto *coercion variables* and *dictionaries*
       -- One reason for putting coercion variable here  I think
       --      is to ensure their kinds are zonked
-      pat_dicts :: [EvVar]
+      cpt_dicts :: [EvVar]
 
     , -- | Bindings involving those dictionaries
-      pat_binds :: TcEvBinds
+      cpt_binds :: TcEvBinds
 
     , -- ^ Extra wrapper to pass to the matcher
       -- Only relevant for pattern-synonyms;
       --   ignored for data cons
-      pat_wrap  :: HsWrapper
+      cpt_wrap  :: HsWrapper
     }
 
 -- | Coercion Pattern (translation only)
@@ -360,7 +360,7 @@ data CoPat
     { -- | Coercion Pattern
       -- If co :: t1 ~ t2, p :: t2,
       -- then (CoPat co p) :: t1
-      co_pat_wrap :: HsWrapper
+      co_cpt_wrap :: HsWrapper
 
     , -- | Why not LPat?  Ans: existing locn will do
       co_pat_inner :: Pat GhcTc
@@ -523,16 +523,14 @@ pprParendLPat :: (OutputableBndrId p)
               => PprPrec -> LPat (GhcPass p) -> SDoc
 pprParendLPat p = pprParendPat p . unLoc
 
-pprParendPat
-  :: forall p
-  .  OutputableBndrId p
-  => PprPrec
-  -> Pat (GhcPass p)
-  -> SDoc
+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
+    else pprPat pat
   where
     need_parens print_tc_elab pat
       | GhcTc <- ghcPass @p
@@ -547,7 +545,7 @@ pprParendPat p pat = sdocOption sdocPrintTypecheckerElaboration $ \ print_tc_ela
       -- But otherwise the CoPat is discarded, so it
       -- is the pattern inside that matters.  Sigh.
 
-pprPat :: forall p. (IsPass p, OutputableBndrId p) => Pat (GhcPass p) -> SDoc
+pprPat :: forall p. (OutputableBndrId p) => Pat (GhcPass p) -> SDoc
 pprPat (VarPat _ lvar)          = pprPatBndr (unLoc lvar)
 pprPat (WildPat _)              = char '_'
 pprPat (LazyPat _ pat)          = char '~' <> pprParendLPat appPrec pat
@@ -591,16 +589,16 @@ pprPat (ConPat { pat_con = con
           -- error message, and we want to make sure it prints nicely
           ppr con
             <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
-                           , pprIfTc @p $ ppr binds ])
+                           , ppr binds ])
             <+> pprConArgs details
-        where ConPatTc { pat_tvs = tvs
-                       , pat_dicts = dicts
-                       , pat_binds = binds
+        where ConPatTc { cpt_tvs = tvs
+                       , cpt_dicts = dicts
+                       , cpt_binds = binds
                        } = ext
 pprPat (XPat ext) = case ghcPass @p of
   GhcPs -> noExtCon ext
   GhcRn -> noExtCon ext
-  GhcTc -> pprIfTc @p $ pprHsWrapper co $ \parens ->
+  GhcTc -> pprHsWrapper co $ \parens ->
       if parens
       then pprParendPat appPrec pat
       else pprPat pat
@@ -643,24 +641,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 $ ConPat { pat_con = noLoc (RealDataCon dc)
                    , pat_args = PrefixCon pats
                    , pat_con_ext = ConPatTc
-                     { pat_tvs = []
-                     , pat_dicts = []
-                     , pat_binds = emptyTcEvBinds
-                     , pat_arg_tys = tys
-                     , pat_wrap = idHsWrapper
+                     { cpt_tvs = []
+                     , cpt_dicts = []
+                     , cpt_binds = emptyTcEvBinds
+                     , cpt_arg_tys = tys
+                     , cpt_wrap = idHsWrapper
                      }
                    }
 
-mkNilPat :: Type -> OutPat (GhcPass p)
+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)] []
 
@@ -728,7 +726,7 @@ looksLazyPat (VarPat {})   = False
 looksLazyPat (WildPat {})  = False
 looksLazyPat _             = True
 
-isIrrefutableHsPat :: forall p. (IsPass p, 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
@@ -867,11 +865,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 at .
-parenthesizePat
-  :: IsPass p
-  => 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
@@ -900,7 +897,7 @@ collectEvVarsPat pat =
     ConPat
       { pat_args  = args
       , pat_con_ext = ConPatTc
-        { pat_dicts = dicts
+        { cpt_dicts = dicts
         }
       }
                      -> unionBags (listToBag dicts)


=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -91,7 +91,7 @@ module GHC.Hs.Utils(
   collectPatBinders, collectPatsBinders,
   collectLStmtsBinders, collectStmtsBinders,
   collectLStmtBinders, collectStmtBinders,
-  XCollectPat(..),
+  CollectPass(..),
 
   hsLTyClDeclBinders, hsTyClForeignBinders,
   hsPatSynSelectors, getPatSynBinds,
@@ -200,12 +200,11 @@ mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct)
 mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
 mkHsAppTypes = foldl' mkHsAppType
 
-mkHsLam
-  :: IsPass p
-  => (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
@@ -444,38 +443,41 @@ nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
 
 nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs
 nlInfixConPat con l r = noLoc $ ConPat
-  (noLoc con)
-  (InfixCon (parenthesizePat opPrec l)
-            (parenthesizePat opPrec r))
-  noExtField
+  { 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 $ ConPat
-  (noLoc con)
-  (PrefixCon (map (parenthesizePat appPrec) pats))
-  noExtField
+  { 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 $ ConPat
-  (noLoc con)
-  (PrefixCon (map (parenthesizePat appPrec) pats))
-  noExtField
-
-nlNullaryConPat
-  :: ( XConPatCon (GhcPass p) ~ IdP (GhcPass p)
-     , XConPat (GhcPass p) ~ NoExtField
-     )
-  => IdP (GhcPass p)
-  -> LPat (GhcPass p)
-nlNullaryConPat con = noLoc $ ConPat (noLoc con) (PrefixCon []) noExtField
+  { 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 $ ConPat
-  (noLoc $ getRdrName con)
-  (PrefixCon $
+  { pat_con_ext = noExtField
+  , pat_con = noLoc $ getRdrName con
+  , pat_args = PrefixCon $
      replicate (dataConSourceArity con)
-               nlWildPat)
-  noExtField
+               nlWildPat
+  }
 
 -- | Wildcard pattern - after parsing
 nlWildPat :: LPat GhcPs
@@ -897,14 +899,12 @@ mkPrefixFunRhs n = FunRhs { mc_fun = n
                           , mc_strictness = NoSrcStrict }
 
 ------------
-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 :: 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
   = noLoc (Match { m_ext   = noExtField
                  , m_ctxt  = ctxt
@@ -1001,74 +1001,70 @@ isBangedHsBind (PatBind {pat_lhs = pat})
 isBangedHsBind _
   = False
 
-collectLocalBinders
-  :: XCollectPat (GhcPass idL)
-  => HsLocalBindsLR (GhcPass idL) (GhcPass idR)
-  -> [IdP (GhcPass idL)]
+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 _) = []
 collectLocalBinders (XHsLocalBindsLR _) = []
 
-collectHsIdBinders, collectHsValBinders
-  :: XCollectPat (GhcPass idL)
-  => 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
-  :: XCollectPat p
-  => HsBindLR p idR -> [IdP p]
+collectHsBindBinders :: CollectPass p
+                     => HsBindLR p idR
+                     -> [IdP p]
 -- ^ Collect both 'Id's and pattern-synonym binders
 collectHsBindBinders b = collect_bind False b []
 
-collectHsBindsBinders
-  :: XCollectPat p
-  => LHsBindsLR p idR
-  -> [IdP p]
+collectHsBindsBinders :: CollectPass p
+                      => LHsBindsLR p idR
+                      -> [IdP p]
 collectHsBindsBinders binds = collect_binds False binds []
 
-collectHsBindListBinders
-  :: XCollectPat p
-  => [LHsBindLR p idR]
-  -> [IdP 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
-  :: XCollectPat (GhcPass idL)
-  => Bool
-  -> HsValBindsLR (GhcPass idL) (GhcPass idR)
-  -> [IdP (GhcPass idL)]
+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
-  :: XCollectPat p
-  => Bool
-  -> [(RecFlag, LHsBinds p)]
-  -> [IdP p]
+collect_out_binds :: CollectPass p
+                  => Bool
+                  -> [(RecFlag, LHsBinds p)]
+                  -> [IdP p]
 collect_out_binds ps = foldr (collect_binds ps . snd) []
 
-collect_binds
-  :: XCollectPat p
-  => Bool
-  -> LHsBindsLR p idR
-  -> [IdP p]
-  -> [IdP 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
-  :: XCollectPat p
-  => Bool
-  -> HsBindLR p idR
-  -> [IdP p]
-  -> [IdP p]
+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
@@ -1092,25 +1088,24 @@ collectMethodBinders binds = foldr (get . unLoc) [] binds
        -- Someone else complains about non-FunBinds
 
 ----------------- Statements --------------------------
-collectLStmtsBinders :: (XCollectPat (GhcPass idL))
+collectLStmtsBinders :: (CollectPass (GhcPass idL))
                      => [LStmtLR (GhcPass idL) (GhcPass idR) body]
                      -> [IdP (GhcPass idL)]
 collectLStmtsBinders = concatMap collectLStmtBinders
 
-collectStmtsBinders :: (XCollectPat (GhcPass idL))
+collectStmtsBinders :: (CollectPass (GhcPass idL))
                     => [StmtLR (GhcPass idL) (GhcPass idR) body]
                     -> [IdP (GhcPass idL)]
 collectStmtsBinders = concatMap collectStmtBinders
 
-collectLStmtBinders :: (XCollectPat (GhcPass idL))
+collectLStmtBinders :: (CollectPass (GhcPass idL))
                     => LStmtLR (GhcPass idL) (GhcPass idR) body
                     -> [IdP (GhcPass idL)]
 collectLStmtBinders = collectStmtBinders . unLoc
 
-collectStmtBinders
-  :: (XCollectPat (GhcPass idL))
-  => StmtLR (GhcPass idL) (GhcPass idR) body
-  -> [IdP (GhcPass idL)]
+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
 collectStmtBinders (LetStmt _  binds)      = collectLocalBinders (unLoc binds)
@@ -1129,25 +1124,21 @@ collectStmtBinders (XStmtLR nec) = noExtCon nec
 
 
 ----------------- Patterns --------------------------
-collectPatBinders :: XCollectPat p => LPat p -> [IdP p]
+collectPatBinders :: CollectPass p => LPat p -> [IdP p]
 collectPatBinders pat = collect_lpat pat []
 
-collectPatsBinders :: XCollectPat p => [LPat p] -> [IdP p]
+collectPatsBinders :: CollectPass p => [LPat p] -> [IdP p]
 collectPatsBinders pats = foldr collect_lpat [] pats
 
 -------------
-collect_lpat
-  :: forall pass.
-     (XCollectPat pass)
-  => LPat pass -> [IdP pass] -> [IdP pass]
+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.
-     XCollectPat p
-  => Pat p
-  -> [IdP p]
-  -> [IdP p]
+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
@@ -1168,19 +1159,22 @@ collect_pat pat bndrs = case pat of
   (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
                           -> collect_pat pat bndrs
   (SplicePat _ _)         -> bndrs
-  (XPat ext)              -> collectPatX (Proxy @p) ext bndrs
+  (XPat ext)              -> collectXXPat (Proxy @p) ext bndrs
 
-class (XRec p Pat ~ Located (Pat p)) => XCollectPat p where
-  collectPatX :: Proxy p -> XXPat p -> [IdP p] -> [IdP p]
+-- 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.
+class (XRec p Pat ~ Located (Pat p)) => CollectPass p where
+  collectXXPat :: Proxy p -> XXPat p -> [IdP p] -> [IdP p]
 
-instance XCollectPat (GhcPass 'Parsed) where
-  collectPatX _ ext = noExtCon ext
+instance CollectPass (GhcPass 'Parsed) where
+  collectXXPat _ ext = noExtCon ext
 
-instance XCollectPat (GhcPass 'Renamed) where
-  collectPatX _ ext = noExtCon ext
+instance CollectPass (GhcPass 'Renamed) where
+  collectXXPat _ ext = noExtCon ext
 
-instance XCollectPat (GhcPass 'Typechecked) where
-  collectPatX _ (CoPat _ pat _) = collect_pat pat
+instance CollectPass (GhcPass 'Typechecked) where
+  collectXXPat _ (CoPat _ pat _) = collect_pat pat
 
 
 {-


=====================================
compiler/GHC/HsToCore/Arrows.hs
=====================================
@@ -1196,7 +1196,7 @@ Note [Dictionary binders in ConPatOut] See also same Note in GHC.Hs.Utils
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The following functions to collect value variables from patterns are
 copied from GHC.Hs.Utils, with one change: we also collect the dictionary
-bindings (pat_binds) from ConPatOut.  We need them for cases like
+bindings (cpt_binds) from ConPatOut.  We need them for cases like
 
 h :: Arrow a => Int -> a (Int,Int) Int
 h x = proc (y,z) -> case compare x y of
@@ -1237,7 +1237,7 @@ collectl (L _ pat) bndrs
     go (SumPat _ pat _ _)         = collectl pat bndrs
 
     go (ConPat { pat_args = ps
-               , pat_con_ext = ConPatTc { pat_binds = ds }}) =
+               , pat_con_ext = ConPatTc { cpt_binds = ds }}) =
                                     collectEvBinders ds
                                     ++ foldr collectl bndrs (hsConPatArgs ps)
     go (LitPat _ _)               = bndrs


=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -117,10 +117,9 @@ user-written. This lets us relate Names (from ClsInsts) to comments
 (associated with InstDecls and DerivDecls).
 -}
 
-getMainDeclBinder
-  :: (XCollectPat (GhcPass p))
-  => HsDecl (GhcPass p)
-  -> [IdP (GhcPass p)]
+getMainDeclBinder :: (CollectPass (GhcPass p))
+                  => HsDecl (GhcPass p)
+                  -> [IdP (GhcPass p)]
 getMainDeclBinder (TyClD _ d) = [tcdName d]
 getMainDeclBinder (ValD _ d) =
   case collectHsBindBinders d of


=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -708,11 +708,11 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
                  pat = noLoc $ ConPat { pat_con = noLoc con
                                       , pat_args = PrefixCon $ map nlVarPat arg_ids
                                       , pat_con_ext = ConPatTc
-                                        { pat_tvs = ex_tvs
-                                        , pat_dicts = eqs_vars ++ theta_vars
-                                        , pat_binds = emptyTcEvBinds
-                                        , pat_arg_tys = in_inst_tys
-                                        , pat_wrap = req_wrap
+                                        { cpt_tvs = ex_tvs
+                                        , cpt_dicts = eqs_vars ++ theta_vars
+                                        , cpt_binds = emptyTcEvBinds
+                                        , cpt_arg_tys = in_inst_tys
+                                        , cpt_wrap = req_wrap
                                         }
                                       }
            ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }


=====================================
compiler/GHC/HsToCore/ListComp.hs
=====================================
@@ -270,7 +270,7 @@ deListComp (ApplicativeStmt {} : _) _ =
 deListComp (XStmtLR nec : _) _ =
   noExtCon nec
 
-deBindComp :: OutPat GhcTc
+deBindComp :: LPat GhcTc
            -> CoreExpr
            -> [ExprStmt GhcTc]
            -> CoreExpr


=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -525,7 +525,7 @@ tidy_bang_pat v o _ p@(SumPat {})    = tidy1 v o p
 tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc)
                               , pat_args = args
                               , pat_con_ext = ConPatTc
-                                { pat_arg_tys = arg_tys
+                                { cpt_arg_tys = arg_tys
                                 }
                               })
   -- Newtypes: push bang inwards (#9844)
@@ -1124,7 +1124,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
 
 patGroup :: Platform -> Pat GhcTc -> PatGroup
 patGroup _ (ConPat { pat_con = L _ con
-                   , pat_con_ext = ConPatTc { pat_arg_tys = tys }
+                   , pat_con_ext = ConPatTc { cpt_arg_tys = tys }
                    })
  | RealDataCon dcon <- con              = PgCon dcon
  | PatSynCon psyn <- con                = PgSyn psyn tys


=====================================
compiler/GHC/HsToCore/Match/Constructor.hs
=====================================
@@ -147,9 +147,9 @@ matchOneConLike vars ty (eqn1 :| eqns)   -- All eqns for a single constructor
                              { eqn_pats = ConPat
                                { pat_args = args
                                , pat_con_ext = ConPatTc
-                                 { pat_tvs = tvs
-                                 , pat_dicts = ds
-                                 , pat_binds = bind
+                                 { cpt_tvs = tvs
+                                 , cpt_dicts = ds
+                                 , cpt_binds = bind
                                  }
                                } : pats
                              }))
@@ -181,10 +181,10 @@ matchOneConLike vars ty (eqn1 :| eqns)   -- All eqns for a single constructor
     ConPat { pat_con = L _ con1
            , pat_args = args1
            , pat_con_ext = ConPatTc
-             { pat_arg_tys = arg_tys
-             , pat_wrap = wrapper1
-             , pat_tvs = tvs1
-             , pat_dicts = dicts1
+             { cpt_arg_tys = arg_tys
+             , cpt_wrap = wrapper1
+             , cpt_tvs = tvs1
+             , cpt_dicts = dicts1
              }
            } = firstPat eqn1
     fields1 = map flSelector (conLikeFieldLabels con1)


=====================================
compiler/GHC/HsToCore/PmCheck.hs
=====================================
@@ -502,9 +502,9 @@ translatePat fam_insts x pat = case pat of
   ConPat { pat_con     = L _ con
          , pat_args    = ps
          , pat_con_ext = ConPatTc
-           { pat_arg_tys = arg_tys
-           , pat_tvs     = ex_tvs
-           , pat_dicts   = dicts
+           { cpt_arg_tys = arg_tys
+           , cpt_tvs     = ex_tvs
+           , cpt_dicts   = dicts
            }
          } -> do
     translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps


=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1984,7 +1984,7 @@ repP (TuplePat _ ps boxed)
   | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }
 repP (SumPat _ p alt arity) = do { p1 <- repLP p
                                  ; repPunboxedSum p1 alt arity }
-repP (ConPat dc details NoExtField)
+repP (ConPat NoExtField dc details)
  = do { con_str <- lookupLOcc dc
       ; case details of
          PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }


=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -760,7 +760,7 @@ mkLHsPatTup [lpat] = lpat
 mkLHsPatTup lpats  = L (getLoc (head lpats)) $
                      mkVanillaTuplePat lpats Boxed
 
-mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
+mkVanillaTuplePat :: [LPat GhcTc] -> Boxity -> Pat GhcTc
 -- A vanilla tuple pattern simply gets its type from its sub-patterns
 mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
 


=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -468,14 +468,14 @@ rnPatAndThen mk p@(ViewPat x expr pat)
        -- ; return (ViewPat expr' pat' ty) }
        ; return (ViewPat x expr' pat') }
 
-rnPatAndThen mk (ConPat con stuff NoExtField)
+rnPatAndThen mk (ConPat NoExtField con args)
    -- rnConPatAndThen takes care of reconstructing the pattern
    -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.
   = case unLoc con == nameRdrName (dataConName nilDataCon) of
       True    -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists
                     ; if ol_flag then rnPatAndThen mk (ListPat noExtField [])
-                                 else rnConPatAndThen mk con stuff}
-      False   -> rnConPatAndThen mk con stuff
+                                 else rnConPatAndThen mk con args}
+      False   -> rnConPatAndThen mk con args
 
 rnPatAndThen mk (ListPat _ pats)
   = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists
@@ -517,7 +517,12 @@ rnConPatAndThen :: NameMaker
 rnConPatAndThen mk con (PrefixCon pats)
   = do  { con' <- lookupConCps con
         ; pats' <- rnLPatsAndThen mk pats
-        ; return (ConPat con' (PrefixCon pats') NoExtField) }
+        ; return $ ConPat
+            { pat_con_ext = noExtField
+            , pat_con = con'
+            , pat_args = PrefixCon pats'
+            }
+        }
 
 rnConPatAndThen mk con (InfixCon pat1 pat2)
   = do  { con' <- lookupConCps con
@@ -529,7 +534,12 @@ rnConPatAndThen mk con (InfixCon pat1 pat2)
 rnConPatAndThen mk con (RecCon rpats)
   = do  { con' <- lookupConCps con
         ; rpats' <- rnHsRecPatsAndThen mk con' rpats
-        ; return (ConPat con' (RecCon rpats') NoExtField) }
+        ; return $ ConPat
+            { pat_con_ext = noExtField
+            , pat_con = con'
+            , pat_args = RecCon rpats'
+            }
+        }
 
 checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn ()
 checkUnusedRecordWildcardCps loc dotdot_names =


=====================================
compiler/GHC/Rename/Types.hs
=====================================
@@ -1231,27 +1231,46 @@ mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
 mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn
              -> RnM (Pat GhcRn)
 
-mkConOpPatRn op2 fix2 p1@(L loc (ConPat op1 (InfixCon p11 p12) NoExtField)) p2
+mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p11 p12))) p2
   = do  { fix1 <- lookupFixityRn (unLoc op1)
         ; let (nofix_error, associate_right) = compareFixity fix1 fix2
 
         ; if nofix_error then do
                 { precParseErr (NormalOp (unLoc op1),fix1)
                                (NormalOp (unLoc op2),fix2)
-                ; return (ConPat op2 (InfixCon p1 p2) NoExtField) }
+                ; return $ ConPat
+                    { pat_con_ext = noExtField
+                    , pat_con = op2
+                    , pat_args = InfixCon p1 p2
+                    }
+                }
 
           else if associate_right then do
                 { new_p <- mkConOpPatRn op2 fix2 p12 p2
-                ; return (ConPat op1 (InfixCon p11 (L loc new_p)) NoExtField) }
+                ; return $ ConPat
+                    { pat_con_ext = noExtField
+                    , pat_con = op1
+                    , pat_args = InfixCon p11 (L loc new_p)
+                    }
+                }
                 -- XXX loc right?
-          else return (ConPat op2 (InfixCon p1 p2) NoExtField) }
+          else return $ ConPat
+                 { pat_con_ext = noExtField
+                 , pat_con = op2
+                 , pat_args = InfixCon p1 p2
+                 }
+        }
 
 mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment
   = ASSERT( not_op_pat (unLoc p2) )
-    return (ConPat op (InfixCon p1 p2) NoExtField)
+    return $ ConPat
+      { pat_con_ext = noExtField
+      , pat_con = op
+      , pat_args = InfixCon p1 p2
+      }
 
 not_op_pat :: Pat GhcRn -> Bool
-not_op_pat (ConPat _ (InfixCon _ _) NoExtField) = False
+not_op_pat (ConPat NoExtField _ (InfixCon _ _)) = False
 not_op_pat _                                    = True
 
 --------------------------------------
@@ -1281,7 +1300,7 @@ checkPrecMatch op (MG { mg_alts = (L _ ms) })
 checkPrecMatch _ (XMatchGroup nec) = noExtCon nec
 
 checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
-checkPrec op (ConPat op1 (InfixCon _ _) NoExtField) right = do
+checkPrec op (ConPat NoExtField op1 (InfixCon _ _)) right = do
     op_fix@(Fixity _ op_prec  op_dir) <- lookupFixityRn op
     op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
     let


=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1270,13 +1270,21 @@ cvtp (UnboxedSumP p alt arity)
                             ; return $ SumPat noExtField p' alt arity }
 cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps
                             ; let pps = map (parenthesizePat appPrec) ps'
-                            ; return $ ConPat s' (PrefixCon pps) NoExtField }
+                            ; return $ ConPat
+                                { pat_con_ext = noExtField
+                                , pat_con = s'
+                                , pat_args = PrefixCon pps
+                                }
+                            }
 cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
                             ; wrapParL (ParPat noExtField) $
-                              ConPat s'
-                                (InfixCon (parenthesizePat opPrec p1')
-                                          (parenthesizePat opPrec p2'))
-                                NoExtField
+                              ConPat
+                                { pat_con_ext = NoExtField
+                                , pat_con = s'
+                                , pat_args = InfixCon
+                                    (parenthesizePat opPrec p1')
+                                    (parenthesizePat opPrec p2')
+                                }
                             }
                             -- See Note [Operator association]
 cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
@@ -1290,9 +1298,11 @@ cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p
                             ; return $ AsPat noExtField s' p' }
 cvtp TH.WildP          = return $ WildPat noExtField
 cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
-                            ; return $ ConPat c'
-                                (Hs.RecCon $ HsRecFields fs' Nothing)
-                                NoExtField
+                            ; return $ ConPat
+                                { pat_con_ext = noExtField
+                                , pat_con = c'
+                                , pat_args = Hs.RecCon $ HsRecFields fs' Nothing
+                                }
                             }
 cvtp (ListP ps)        = do { ps' <- cvtPats ps
                             ; return
@@ -1323,7 +1333,11 @@ cvtOpAppP x op1 (UInfixP y op2 z)
 cvtOpAppP x op y
   = do { op' <- cNameL op
        ; y' <- cvtPat y
-       ; return $ ConPat op' (InfixCon x y') NoExtField
+       ; return $ ConPat
+          { pat_con_ext = noExtField
+          , pat_con = op'
+          , pat_args = InfixCon x y'
+          }
        }
 
 -----------------------------------------------------------


=====================================
compiler/parser/RdrHsSyn.hs
=====================================
@@ -603,7 +603,7 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =
        ; return $ mkMatchGroup FromSource matches }
   where
     fromDecl (L loc decl@(ValD _ (PatBind _
-                         pat@(L _ (ConPat ln@(L _ name) details NoExtField))
+                         pat@(L _ (ConPat NoExtField ln@(L _ name) details))
                                rhs _))) =
         do { unless (name == patsyn_name) $
                wrongNameBindingErr loc decl
@@ -1077,7 +1077,11 @@ checkLPat e@(L l _) = checkPat l e []
 checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs]
          -> PV (LPat GhcPs)
 checkPat loc (L l e@(PatBuilderVar (L _ c))) args
-  | isRdrDataCon c = return (L loc (ConPat (L l c) (PrefixCon args) NoExtField))
+  | isRdrDataCon c = return . L loc $ ConPat
+      { pat_con_ext = noExtField
+      , pat_con = L l c
+      , pat_args = PrefixCon args
+      }
   | not (null args) && patIsRec c =
       localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $
       patFail l (ppr e)
@@ -1114,7 +1118,11 @@ checkAPat loc e0 = do
      | isRdrDataCon c -> do
          l <- checkLPat l
          r <- checkLPat r
-         return (ConPat (L cl c) (InfixCon l r) NoExtField)
+         return $ ConPat
+           { pat_con_ext = noExtField
+           , pat_con = L cl c
+           , pat_args = InfixCon l r
+           }
 
    PatBuilderPar e    -> checkLPat e >>= (return . (ParPat noExtField))
    _           -> patFail loc (ppr e0)
@@ -2065,7 +2073,11 @@ mkPatRec ::
 mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd)
   | isRdrDataCon (unLoc c)
   = do fs <- mapM checkPatField fs
-       return $ PatBuilderPat $ ConPat c (RecCon (HsRecFields fs dd)) NoExtField
+       return $ PatBuilderPat $ ConPat
+         { pat_con_ext = noExtField
+         , pat_con = c
+         , pat_args = RecCon (HsRecFields fs dd)
+         }
 mkPatRec p _ =
   addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p
 


=====================================
compiler/typecheck/TcArrows.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 $


=====================================
compiler/typecheck/TcBinds.hs
=====================================
@@ -505,7 +505,7 @@ 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, XCollectPat (GhcPass p))
+     (OutputableBndrId p, CollectPass (GhcPass p))
   => SrcSpan -- ^ The location of the first pattern synonym binding
              --   (for error reporting)
   -> LHsBinds (GhcPass p)


=====================================
compiler/typecheck/TcGenDeriv.hs
=====================================
@@ -534,10 +534,12 @@ unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
 nlConWildPat :: DataCon -> LPat GhcPs
 -- The pattern (K {})
 nlConWildPat con = noLoc $ ConPat
-  (noLoc $ getRdrName con)
-  (RecCon $ HsRecFields { rec_flds = []
-                        , rec_dotdot = Nothing })
-  NoExtField
+  { pat_con_ext = noExtField
+  , pat_con = noLoc $ getRdrName con
+  , pat_args = RecCon $ HsRecFields
+      { rec_flds = []
+      , rec_dotdot = Nothing }
+  }
 
 {-
 ************************************************************************


=====================================
compiler/typecheck/TcHsSyn.hs
=====================================
@@ -118,7 +118,7 @@ hsPatType (TuplePat tys _ bx)           = mkTupleTy1 bx tys
 hsPatType (SumPat tys _ _ _ )           = mkSumTy tys
 hsPatType (ConPat { pat_con = lcon
                   , pat_con_ext = ConPatTc
-                    { pat_arg_tys = tys
+                    { cpt_arg_tys = tys
                     }
                   })
                                         = conLikeResTy (unLoc lcon) tys
@@ -1309,7 +1309,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)
@@ -1374,11 +1374,11 @@ zonk_pat env (SumPat tys pat alt arity )
 zonk_pat env p@(ConPat { pat_con = L _ con
                        , pat_args = args
                        , pat_con_ext = p'@(ConPatTc
-                         { pat_tvs = tyvars
-                         , pat_dicts = evs
-                         , pat_binds = binds
-                         , pat_wrap = wrapper
-                         , pat_arg_tys = tys
+                         { cpt_tvs = tyvars
+                         , cpt_dicts = evs
+                         , cpt_binds = binds
+                         , cpt_wrap = wrapper
+                         , cpt_arg_tys = tys
                          })
                        })
   = ASSERT( all isImmutableTyVar tyvars )
@@ -1404,11 +1404,11 @@ zonk_pat env p@(ConPat { pat_con = L _ con
                , p
                  { pat_args = new_args
                  , pat_con_ext = p'
-                   { pat_arg_tys = new_tys
-                   , pat_tvs = new_tyvars
-                   , pat_dicts = new_evs
-                   , pat_binds = new_binds
-                   , pat_wrap = new_wrapper
+                   { cpt_arg_tys = new_tys
+                   , cpt_tvs = new_tyvars
+                   , cpt_dicts = new_evs
+                   , cpt_binds = new_binds
+                   , cpt_wrap = new_wrapper
                    }
                  }
                )
@@ -1454,9 +1454,9 @@ 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') }
@@ -1475,7 +1475,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


=====================================
compiler/typecheck/TcPat.hs
=====================================
@@ -495,7 +495,7 @@ tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside
 
 ------------------------
 -- Data constructors
-tc_pat penv (ConPat con arg_pats NoExtField) 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
 
 ------------------------
@@ -789,10 +789,10 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty
                   ; let res_pat = ConPat { pat_con = header
                                          , pat_args = arg_pats'
                                          , pat_con_ext = ConPatTc
-                                           { pat_tvs = [], pat_dicts = []
-                                           , pat_binds = emptyTcEvBinds
-                                           , pat_arg_tys = ctxt_res_tys
-                                           , pat_wrap = idHsWrapper
+                                           { cpt_tvs = [], cpt_dicts = []
+                                           , cpt_binds = emptyTcEvBinds
+                                           , cpt_arg_tys = ctxt_res_tys
+                                           , cpt_wrap = idHsWrapper
                                            }
                                          }
 
@@ -827,11 +827,11 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty
                 { pat_con   = header
                 , pat_args  = arg_pats'
                 , pat_con_ext = ConPatTc
-                  { pat_tvs   = ex_tvs'
-                  , pat_dicts = given
-                  , pat_binds = ev_binds
-                  , pat_arg_tys = ctxt_res_tys
-                  , pat_wrap  = idHsWrapper
+                  { 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)
@@ -881,11 +881,11 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
         ; let res_pat = ConPat { pat_con   = L con_span $ PatSynCon pat_syn
                                , pat_args  = arg_pats'
                                , pat_con_ext = ConPatTc
-                                 { pat_tvs   = ex_tvs'
-                                 , pat_dicts = prov_dicts'
-                                 , pat_binds = ev_binds
-                                 , pat_arg_tys = mkTyVarTys univ_tvs'
-                                 , pat_wrap  = req_wrap
+                                 { 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


=====================================
compiler/typecheck/TcPatSyn.hs
=====================================
@@ -942,7 +942,7 @@ tcPatToExpr name args pat = go pat
     go (L loc p) = L loc <$> go1 p
 
     go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn)
-    go1 (ConPat con info NoExtField)
+    go1 (ConPat NoExtField con info)
       = case info of
           PrefixCon ps  -> mkPrefixConExpr con ps
           InfixCon l r  -> mkPrefixConExpr con [l,r]
@@ -1127,7 +1127,7 @@ tcCollectEx pat = go pat
     go1 (SumPat _ p _ _)   = go p
     go1 (ViewPat _ _ p)    = go p
     go1 con at ConPat{ pat_con_ext = con' }
-                           = merge (pat_tvs con', pat_dicts con') $
+                           = merge (cpt_tvs con', cpt_dicts con') $
                               goConDetails $ pat_args con
     go1 (SigPat _ p _)     = go p
     go1 (XPat (CoPat _ p _)) = go1 p


=====================================
compiler/typecheck/TcTyClsDecls.hs
=====================================
@@ -2195,9 +2195,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
@@ -2234,8 +2234,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) $


=====================================
compiler/typecheck/TcTyDecls.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 = ConPat (L loc (getName con)) (RecCon rec_fields) NoExtField
+    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


=====================================
compiler/typecheck/TcValidity.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)) $


=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 46c0d63c0a910a34eb307807ea603ad6728b756c
+Subproject commit 6809c3cc93193c049f296510a1561941b0a92a5e



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/63e007f1f82fb934b2a68a4e39a92cded56523b7

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/63e007f1f82fb934b2a68a4e39a92cded56523b7
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200408/2fd1870f/attachment-0001.html>


More information about the ghc-commits mailing list