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.

3 files changed, 6 insertions, 6 deletions

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