Separate `LPat` from `Pat` on the type-level

Since the Trees That Grow effort started, we had `type LPat = Pat`.
This is so that `SrcLoc`s would only be annotated in GHC's AST, which is
the reason why all GHC passes use the extension constructor `XPat` to
attach source locations. See #15495 for the design discussion behind
that.

But now suddenly there are `XPat`s everywhere!
There are several functions which dont't cope with `XPat`s by either
crashing (`hsPatType`) or simply returning incorrect results
(`collectEvVarsPat`).

This issue was raised in #17330. I also came up with a rather clean and
type-safe solution to the problem: We define

```haskell
type family XRec p (f :: * -> *) = r | r -> p f
type instance XRec (GhcPass p) f = Located (f (GhcPass p))
type instance XRec TH          f =          f p
type LPat p = XRec p Pat
```

This is a rather modular embedding of the old "ping-pong" style, while
we only pay for the `Located` wrapper within GHC. No ping-ponging in
a potential Template Haskell AST, for example. Yet, we miss no case
where we should've handled a `SrcLoc`: `hsPatType` and
`collectEvVarsPat` are not callable at an `LPat`.

Also, this gets rid of one indirection in `Located` variants:
Previously, we'd have to go through `XPat` and `Located` to get from
`LPat` to the wrapped `Pat`. Now it's just `Located` again.

Thus we fix #17330.

12 files changed, 61 insertions, 77 deletions

diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index b73855eb7a..6b1042700a 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilyDependencies #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -143,6 +144,12 @@ type GhcRn   = GhcPass 'Renamed     -- Old 'Name' type param
 type GhcTc   = GhcPass 'Typechecked -- Old 'Id' type para,
 type GhcTcId = GhcTc                -- Old 'TcId' type param
 
+-- | GHC's L prefixed variants wrap their vanilla variant in this type family,
+-- to add 'SrcLoc' info via 'Located'. Other passes than 'GhcPass' not
+-- interested in location information can define this instance as @f p@.
+type family XRec p (f :: * -> *) = r | r -> p f
+type instance XRec (GhcPass p) f = Located (f (GhcPass p))
+
 -- | Maps the "normal" id type for a given pass
 type family IdP p
 type instance IdP GhcPs = RdrName
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 25b0a1e184..0fa6dca7b8 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -72,7 +72,7 @@ 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 = Pat p
+type LPat p = XRec p Pat
 
 -- | Pattern
 --
@@ -326,34 +326,8 @@ type instance XSigPat GhcRn = NoExtField
 type instance XSigPat GhcTc = Type
 
 type instance XCoPat  (GhcPass _) = NoExtField
-type instance XXPat   (GhcPass p) = Located (Pat (GhcPass p))
-
-
-{-
-************************************************************************
-*                                                                      *
-*              HasSrcSpan Instance
-*                                                                      *
-************************************************************************
--}
-
-type instance SrcSpanLess (LPat (GhcPass p)) = Pat (GhcPass p)
-instance HasSrcSpan (LPat (GhcPass p)) where
-  -- NB: The following chooses the behaviour of the outer location
-  --     wrapper replacing the inner ones.
-  composeSrcSpan (L sp p) =  if sp == noSrcSpan
-                             then p
-                             else XPat (L sp (stripSrcSpanPat p))
-
-  -- NB: The following only returns the top-level location, if any.
-  decomposeSrcSpan (XPat (L sp p)) = L sp (stripSrcSpanPat p)
-  decomposeSrcSpan p               = L noSrcSpan p
-
-stripSrcSpanPat :: LPat (GhcPass p) -> Pat (GhcPass p)
-stripSrcSpanPat (XPat (L _  p)) = stripSrcSpanPat p
-stripSrcSpanPat p               = p
-
 
+type instance XXPat   (GhcPass _) = NoExtCon
 
 -- ---------------------------------------------------------------------
 
@@ -574,7 +548,7 @@ pprPat (ConPatOut { pat_con = con
                          , ppr binds])
           <+> pprConArgs details
     else pprUserCon (unLoc con) details
-pprPat (XPat x)               = ppr x
+pprPat (XPat n)                 = noExtCon n
 
 
 pprUserCon :: (OutputableBndr con, OutputableBndrId p)
diff --git a/compiler/GHC/Hs/Pat.hs-boot b/compiler/GHC/Hs/Pat.hs-boot
index fc5671c27a..b37bf187fd 100644
--- a/compiler/GHC/Hs/Pat.hs-boot
+++ b/compiler/GHC/Hs/Pat.hs-boot
@@ -10,10 +10,10 @@
 module GHC.Hs.Pat where
 
 import Outputable
-import GHC.Hs.Extension ( OutputableBndrId, GhcPass )
+import GHC.Hs.Extension ( OutputableBndrId, GhcPass, XRec )
 
 type role Pat nominal
 data Pat (i :: *)
-type LPat i = Pat i
+type LPat i = XRec i Pat
 
-instance (OutputableBndrId p) => Outputable (Pat (GhcPass p))
+instance OutputableBndrId p => Outputable (Pat (GhcPass p))
diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs
index 5e8a80fdcc..637a8fd7e9 100644
--- a/compiler/GHC/HsToCore/PmCheck.hs
+++ b/compiler/GHC/HsToCore/PmCheck.hs
@@ -470,20 +470,18 @@ translatePat :: FamInstEnvs -> Id -> Pat GhcTc -> DsM GrdVec
 translatePat fam_insts x pat = case pat of
   WildPat  _ty -> pure []
   VarPat _ y   -> pure (mkPmLetVar (unLoc y) x)
-  -- XPat wraps a Located (Pat GhcTc) in GhcTc. The Located part is important
-  XPat     p   -> translatePat fam_insts x (unLoc p)
-  ParPat _ p   -> translatePat fam_insts x p
+  ParPat _ p   -> translateLPat fam_insts x p
   LazyPat _ _  -> pure [] -- like a wildcard
   BangPat _ p  ->
     -- Add the bang in front of the list, because it will happen before any
     -- nested stuff.
-    (PmBang x :) <$> translatePat fam_insts x p
+    (PmBang x :) <$> translateLPat fam_insts x p
 
   -- (x@pat)   ==>   Translate pat with x as match var and handle impedance
   --                 mismatch with incoming match var
-  AsPat _ (dL->L _ y) p -> (mkPmLetVar y x ++) <$> translatePat fam_insts y p
+  AsPat _ (dL->L _ y) p -> (mkPmLetVar y x ++) <$> translateLPat fam_insts y p
 
-  SigPat _ p _ty -> translatePat fam_insts x p
+  SigPat _ p _ty -> translateLPat fam_insts x p
 
   -- See Note [Translate CoPats]
   -- Generally the translation is
@@ -507,7 +505,7 @@ translatePat fam_insts x pat = case pat of
 
   -- (fun -> pat)   ===>   let y = fun x, pat <- y where y is a match var of pat
   ViewPat _arg_ty lexpr pat -> do
-    (y, grds) <- translatePatV fam_insts pat
+    (y, grds) <- translateLPatV fam_insts pat
     fun <- dsLExpr lexpr
     pure $ PmLet y (App fun (Var x)) : grds
 
@@ -576,12 +574,12 @@ translatePat fam_insts x pat = case pat of
     mkPmLitGrds x lit
 
   TuplePat _tys pats boxity -> do
-    (vars, grdss) <- mapAndUnzipM (translatePatV fam_insts) pats
+    (vars, grdss) <- mapAndUnzipM (translateLPatV fam_insts) pats
     let tuple_con = tupleDataCon boxity (length vars)
     pure $ vanillaConGrd x tuple_con vars : concat grdss
 
   SumPat _ty p alt arity -> do
-    (y, grds) <- translatePatV fam_insts p
+    (y, grds) <- translateLPatV fam_insts p
     let sum_con = sumDataCon alt arity
     -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
     pure $ vanillaConGrd x sum_con [y] : grds
@@ -590,6 +588,7 @@ translatePat fam_insts x pat = case pat of
   -- Not supposed to happen
   ConPatIn  {} -> panic "Check.translatePat: ConPatIn"
   SplicePat {} -> panic "Check.translatePat: SplicePat"
+  XPat      n  -> noExtCon n
 
 -- | 'translatePat', but also select and return a new match var.
 translatePatV :: FamInstEnvs -> Pat GhcTc -> DsM (Id, GrdVec)
@@ -598,12 +597,19 @@ translatePatV fam_insts pat = do
   grds <- translatePat fam_insts x pat
   pure (x, grds)
 
+translateLPat :: FamInstEnvs -> Id -> LPat GhcTc -> DsM GrdVec
+translateLPat fam_insts x = translatePat fam_insts x . unLoc
+
+-- | 'translateLPat', but also select and return a new match var.
+translateLPatV :: FamInstEnvs -> LPat GhcTc -> DsM (Id, GrdVec)
+translateLPatV fam_insts = translatePatV fam_insts . unLoc
+
 -- | @translateListPat _ x [p1, ..., pn]@ is basically
 --   @translateConPatOut _ x $(mkListConPatOuts [p1, ..., pn]>@ without ever
 -- constructing the 'ConPatOut's.
-translateListPat :: FamInstEnvs -> Id -> [Pat GhcTc] -> DsM GrdVec
+translateListPat :: FamInstEnvs -> Id -> [LPat GhcTc] -> DsM GrdVec
 translateListPat fam_insts x pats = do
-  vars_and_grdss <- traverse (translatePatV fam_insts) pats
+  vars_and_grdss <- traverse (translateLPatV fam_insts) pats
   mkListGrds x vars_and_grdss
 
 -- | Translate a constructor pattern
@@ -637,7 +643,7 @@ translateConPatOut fam_insts x con univ_tys ex_tvs dicts = \case
       -- Translate the mentioned field patterns. We're doing this first to get
       -- the Ids for pm_con_args.
       let trans_pat (n, pat) = do
-            (var, pvec) <- translatePatV fam_insts pat
+            (var, pvec) <- translateLPatV fam_insts pat
             pure ((n, var), pvec)
       (tagged_vars, arg_grdss) <- mapAndUnzipM trans_pat tagged_pats
 
@@ -667,7 +673,7 @@ translateMatch :: FamInstEnvs -> [Id] -> LMatch GhcTc (LHsExpr GhcTc)
                -> DsM (GrdVec, [GrdVec])
 translateMatch fam_insts vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }))
   = do
-      pats'   <- concat <$> zipWithM (translatePat fam_insts) vars pats
+      pats'   <- concat <$> zipWithM (translateLPat fam_insts) vars pats
       guards' <- mapM (translateGuards fam_insts) guards
       -- tracePm "translateMatch" (vcat [ppr pats, ppr pats', ppr guards, ppr guards'])
       return (pats', guards')
@@ -706,15 +712,15 @@ translateLet _binds = return []
 
 -- | Translate a pattern guard
 --   @pat <- e ==>  let x = e;  <guards for pat <- x>@
-translateBind :: FamInstEnvs -> Pat GhcTc -> LHsExpr GhcTc -> DsM GrdVec
+translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM GrdVec
 translateBind fam_insts p e = dsLExpr e >>= \case
   Var y
     | Nothing <- isDataConId_maybe y
     -- RHS is a variable, so that will allow us to omit the let
-    -> translatePat fam_insts y p
+    -> translateLPat fam_insts y p
   rhs -> do
-    x <- selectMatchVar p
-    (PmLet x rhs :) <$> translatePat fam_insts x p
+    (x, grds) <- translateLPatV fam_insts p
+    pure (PmLet x rhs : grds)
 
 -- | Translate a boolean guard
 --   @e ==>  let x = e; True <- x@
diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs
index 052a852127..ade017208d 100644
--- a/compiler/deSugar/DsArrows.hs
+++ b/compiler/deSugar/DsArrows.hs
@@ -327,7 +327,7 @@ dsProcExpr pat (dL->L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
     fail_expr <- mkFailExpr ProcExpr env_stk_ty
     var <- selectSimpleMatchVarL pat
     match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr
-    let pat_ty = hsPatType pat
+    let pat_ty = hsLPatType pat
     let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty
                     (Lam var match_code)
                     core_cmd
@@ -868,7 +868,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do
 -- but that's likely to be defined in terms of first.
 
 dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do
-    let pat_ty = hsPatType pat
+    let pat_ty = hsLPatType pat
     (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
     let pat_vars = mkVarSet (collectPatBinders pat)
     let
diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs
index 943b00d71d..e826045eb5 100644
--- a/compiler/deSugar/DsListComp.hs
+++ b/compiler/deSugar/DsListComp.hs
@@ -279,7 +279,7 @@ deBindComp pat core_list1 quals core_list2 = do
     let u3_ty@u1_ty = exprType core_list1       -- two names, same thing
 
         -- u1_ty is a [alpha] type, and u2_ty = alpha
-    let u2_ty = hsPatType pat
+    let u2_ty = hsLPatType pat
 
     let res_ty = exprType core_list2
         h_ty   = u1_ty `mkVisFunTy` res_ty
@@ -373,7 +373,7 @@ dfBindComp :: Id -> Id             -- 'c' and 'n'
            -> DsM CoreExpr
 dfBindComp c_id n_id (pat, core_list1) quals = do
     -- find the required type
-    let x_ty   = hsPatType pat
+    let x_ty   = hsLPatType pat
     let b_ty   = idType n_id
 
     -- create some new local id's
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index d03fe05d60..8559e9ae85 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -672,7 +672,7 @@ mkSelectorBinds ticks pat val_expr
   = return (v, [(v, val_expr)])
 
   | is_flat_prod_lpat pat'           -- Special case (B)
-  = do { let pat_ty = hsPatType pat'
+  = do { let pat_ty = hsLPatType pat'
        ; val_var <- newSysLocalDsNoLP pat_ty
 
        ; let mk_bind tick bndr_var
@@ -758,7 +758,7 @@ mkLHsPatTup lpats  = cL (getLoc (head lpats)) $
 
 mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
 -- A vanilla tuple pattern simply gets its type from its sub-patterns
-mkVanillaTuplePat pats box = TuplePat (map hsPatType pats) pats box
+mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
 
 -- The Big equivalents for the source tuple expressions
 mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs
index ca91056e06..50b4422e64 100644
--- a/compiler/hieFile/HieAst.hs
+++ b/compiler/hieFile/HieAst.hs
@@ -478,9 +478,6 @@ instance HasLoc (HsDataDefn GhcRn) where
     -- Most probably the rest will be unhelpful anyway
   loc _ = noSrcSpan
 
-instance HasLoc (Pat (GhcPass a)) where
-  loc (dL -> L l _) = l
-
 {- Note [Real DataCon Name]
 The typechecker subtitutes the conLikeWrapId for the name, but we don't want
 this showing up in the hieFile, so we replace the name in the Id with the
@@ -581,10 +578,10 @@ instance HasType (LHsBind GhcTc) where
       FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)
       _ -> makeNode bind spn
 
-instance HasType (LPat GhcRn) where
+instance HasType (Located (Pat GhcRn)) where
   getTypeNode (dL -> L spn pat) = makeNode pat spn
 
-instance HasType (LPat GhcTc) where
+instance HasType (Located (Pat GhcTc)) where
   getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)
 
 instance HasType (LHsExpr GhcRn) where
@@ -768,7 +765,7 @@ instance ( a ~ GhcPass p
          , ToHie (TScoped (ProtectedSig a))
          , HasType (LPat a)
          , Data (HsSplice a)
-         ) => ToHie (PScoped (LPat (GhcPass p))) where
+         ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where
   toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =
     concatM $ getTypeNode lpat : case opat of
       WildPat _ ->
diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs
index e6c07cf6ba..38ea5ade59 100644
--- a/compiler/typecheck/TcArrows.hs
+++ b/compiler/typecheck/TcArrows.hs
@@ -16,7 +16,7 @@ import {-# SOURCE #-}   TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, t
 
 import GHC.Hs
 import TcMatches
-import TcHsSyn( hsPatType )
+import TcHsSyn( hsLPatType )
 import TcType
 import TcMType
 import TcBinds
@@ -258,7 +258,7 @@ tc_cmd env
         ; let match' = L mtch_loc (Match { m_ext = noExtField
                                          , m_ctxt = LambdaExpr, m_pats = pats'
                                          , m_grhss = grhss' })
-              arg_tys = map hsPatType pats'
+              arg_tys = map hsLPatType pats'
               cmd' = HsCmdLam x (MG { mg_alts = L l [match']
                                     , mg_ext = MatchGroupTc arg_tys res_ty
                                     , mg_origin = origin })
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 744af979b1..601433b99d 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -16,7 +16,7 @@ checker.
 
 module TcHsSyn (
         -- * Extracting types from HsSyn
-        hsLitType, hsPatType,
+        hsLitType, hsPatType, hsLPatType,
 
         -- * Other HsSyn functions
         mkHsDictLet, mkHsApp,
@@ -97,12 +97,15 @@ import Control.Arrow ( second )
 
 -}
 
+hsLPatType :: LPat GhcTc -> Type
+hsLPatType (dL->L _ p) = hsPatType p
+
 hsPatType :: Pat GhcTc -> Type
-hsPatType (ParPat _ pat)                = hsPatType pat
+hsPatType (ParPat _ pat)                = hsLPatType pat
 hsPatType (WildPat ty)                  = ty
 hsPatType (VarPat _ lvar)               = idType (unLoc lvar)
-hsPatType (BangPat _ pat)               = hsPatType pat
-hsPatType (LazyPat _ pat)               = hsPatType pat
+hsPatType (BangPat _ pat)               = hsLPatType pat
+hsPatType (LazyPat _ pat)               = hsLPatType pat
 hsPatType (LitPat _ lit)                = hsLitType lit
 hsPatType (AsPat _ var _)               = idType (unLoc var)
 hsPatType (ViewPat ty _ _)              = ty
@@ -118,8 +121,7 @@ hsPatType (SigPat ty _ _)               = ty
 hsPatType (NPat ty _ _ _)               = ty
 hsPatType (NPlusKPat ty _ _ _ _ _)      = ty
 hsPatType (CoPat _ _ _ ty)              = ty
--- XPat wraps a Located (Pat GhcTc) in GhcTc
-hsPatType (XPat lpat)                   = hsPatType (unLoc lpat)
+hsPatType (XPat n)                      = noExtCon n
 hsPatType ConPatIn{}                    = panic "hsPatType: ConPatIn"
 hsPatType SplicePat{}                   = panic "hsPatType: SplicePat"
 
diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr
index 4612d87cad..2873bfcfaa 100644
--- a/testsuite/tests/parser/should_compile/KindSigs.stderr
+++ b/testsuite/tests/parser/should_compile/KindSigs.stderr
@@ -339,14 +339,12 @@
               {OccName: qux}))
             (Prefix)
             (NoSrcStrict))
-           [(XPat
-             ({ KindSigs.hs:23:5 }
-              (WildPat
-               (NoExtField))))
-           ,(XPat
-             ({ KindSigs.hs:23:7 }
-              (WildPat
-               (NoExtField))))]
+           [({ KindSigs.hs:23:5 }
+             (WildPat
+              (NoExtField)))
+           ,({ KindSigs.hs:23:7 }
+             (WildPat
+              (NoExtField)))]
            (GRHSs
             (NoExtField)
             [({ KindSigs.hs:23:9-12 }
diff --git a/utils/haddock b/utils/haddock
-Subproject fad111e9d3de1a2e86837d3e6f72fe0cf2f6c0a
+Subproject b34ca2554a3440f092f585bb7fc1e9d4b2ca861