Separate `LPat` from `Pat` on the type-levelwip/remove-lpat

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
mostly type-safe solution to the problem: We define

```haskell
data Loc p
type LPat p = Pat (Loc p)
```

And simply only allow `XPat` to occur when there's a `Loc` wrapping the
pass. At the same time, we can disallow any other constructors to occur
in an `LPat` by setting the constructor field extension to `NoExtCon`
for all but `XPat`. We do the same for the plain GHC passes and `XPat`.

ow we have a rather modular embedding of the old "ping-pong" style
inside of a TTG-ified AST. TH doesn't pay in performance, while we
retain type safety for GHC passes.

Thus we fix #17330.

13 files changed, 124 insertions, 55 deletions

diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index 35afc5f8d3..f7808cb736 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -163,6 +163,11 @@ type family NoGhcTcPass (p :: Pass) :: Pass where
   NoGhcTcPass 'Typechecked = 'Renamed
   NoGhcTcPass other        = other
 
+-- | A TTG mixin for adding 'SrcLoc's to the AST.
+data Loc p
+
+type instance IdP (Loc p) = IdP p
+
 -- =====================================================================
 -- Type families for the HsBinds extension points
 
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index b3a33df43c..90f410e9e1 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module GHC.Hs.Instances where
 
@@ -16,7 +17,12 @@ module GHC.Hs.Instances where
 
 import Data.Data hiding ( Fixity )
 
+#include "HsVersions.h"
+
 import GhcPrelude
+import Outputable
+import Util
+
 import GHC.Hs.Extension
 import GHC.Hs.Binds
 import GHC.Hs.Decls
@@ -352,6 +358,28 @@ deriving instance Data (Pat GhcPs)
 deriving instance Data (Pat GhcRn)
 deriving instance Data (Pat GhcTc)
 
+-- deriving instance (DataIdLR p p) => Data (LPat p)
+--
+-- But we define it by hand here because the deriving code can't omit NoExtCon
+-- constructors, because we are not strict in the constructor extension field.
+--
+-- For serialising purposes, we treat LPat as a separate refinement of Pat.
+-- This spares us from the code bloat and boilerplate involved with duplicating
+-- also those other instances for Loc p, i.e. HsRecFields (Loc GhcPs) body, ...
+lpatDataType :: DataType
+lpatDataType = mkDataType "LPat" [lpatXPatConstr]
+
+lpatXPatConstr :: Constr
+lpatXPatConstr = mkConstr lpatDataType "XPat" [] Prefix
+
+instance (Typeable p, Data (Pat (GhcPass p))) => Data (LPat (GhcPass p)) where
+  gfoldl k z (XPat pat) = z XPat `k` pat
+  gfoldl _ _ _          = panic "Data LPat: not XPat"
+  toConstr (XPat _)     = lpatXPatConstr
+  toConstr _            = panic "Data LPat: not XPat"
+  dataTypeOf _          = lpatDataType
+  gunfold k z c         = ASSERT( c == lpatXPatConstr ) (k (z XPat))
+
 deriving instance Data ListPatTc
 
 -- deriving instance (DataIdLR p p, Data body) => Data (HsRecFields p body)
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index fe8a4e88d5..58b871f7c0 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 = Pat (Loc p)
 
 -- | Pattern
 --
@@ -326,8 +326,27 @@ type instance XSigPat GhcRn = NoExtField
 type instance XSigPat GhcTc = Type
 
 type instance XCoPat  (GhcPass _) = NoExtField
-type instance XXPat   (GhcPass p) = Located (Pat (GhcPass p))
 
+type instance XXPat   (GhcPass _) = NoExtCon
+
+-- TTG instances for Loc
+type instance XWildPat   (Loc _) = NoExtCon
+type instance XVarPat    (Loc _) = NoExtCon
+type instance XLazyPat   (Loc _) = NoExtCon
+type instance XAsPat     (Loc _) = NoExtCon
+type instance XParPat    (Loc _) = NoExtCon
+type instance XBangPat   (Loc _) = NoExtCon
+type instance XListPat   (Loc _) = NoExtCon
+type instance XTuplePat  (Loc _) = NoExtCon
+type instance XSumPat    (Loc _) = NoExtCon
+type instance XViewPat   (Loc _) = NoExtCon
+type instance XSplicePat (Loc _) = NoExtCon
+type instance XLitPat    (Loc _) = NoExtCon
+type instance XNPat      (Loc _) = NoExtCon
+type instance XNPlusKPat (Loc _) = NoExtCon
+type instance XSigPat    (Loc _) = NoExtCon
+type instance XCoPat     (Loc _) = NoExtCon
+type instance XXPat      (Loc p) = Located (Pat p)
 
 {-
 ************************************************************************
@@ -337,23 +356,14 @@ type instance XXPat   (GhcPass p) = Located (Pat (GhcPass p))
 ************************************************************************
 -}
 
-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 SrcSpanLess (LPat p) = Pat p
+instance HasSrcSpan (LPat p) where
+  composeSrcSpan (L sp p) = XPat (L sp p)
 
+  decomposeSrcSpan (XPat (L sp p)) = L sp p
+  -- The following case should be redundant by GHC >= 8.8 when we mark all
+  -- constructor extension fields strict
+  decomposeSrcSpan _               = panic "HasSrcSpan LPat: decomposeSrcSpan"
 
 -- ---------------------------------------------------------------------
 
@@ -504,7 +514,10 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl
 ************************************************************************
 -}
 
-instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) where
+instance OutputableBndrId (GhcPass p) => Outputable (LPat (GhcPass p)) where
+    ppr = pprLPat
+
+instance OutputableBndrId (GhcPass p) => Outputable (Pat (GhcPass p)) where
     ppr = pprPat
 
 pprPatBndr :: OutputableBndr name => name -> SDoc
@@ -535,6 +548,12 @@ pprParendPat p pat = sdocWithDynFlags $ \ dflags ->
       -- But otherwise the CoPat is discarded, so it
       -- is the pattern inside that matters.  Sigh.
 
+pprLPat :: (Outputable (Pat (GhcPass p))) => LPat (GhcPass p) -> SDoc
+pprLPat (XPat x) = ppr x
+-- The following case should be redundant by GHC >= 8.8 when we mark all
+-- constructor extension fields strict
+pprLPat _        = panic "pprLPat: not XPat"
+
 pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc
 pprPat (VarPat _ lvar)          = pprPatBndr (unLoc lvar)
 pprPat (WildPat _)              = char '_'
@@ -574,7 +593,9 @@ pprPat (ConPatOut { pat_con = con
                          , ppr binds])
           <+> pprConArgs details
     else pprUserCon (unLoc con) details
-pprPat (XPat x)               = ppr x
+-- The following case should be redundant by GHC >= 8.8 when we mark all
+-- constructor extension fields strict
+pprPat XPat{}                   = panic "pprPat: XPat"
 
 
 pprUserCon :: (OutputableBndr con, OutputableBndrId (GhcPass p))
diff --git a/compiler/GHC/Hs/Pat.hs-boot b/compiler/GHC/Hs/Pat.hs-boot
index 801f481879..d302dd939b 100644
--- a/compiler/GHC/Hs/Pat.hs-boot
+++ b/compiler/GHC/Hs/Pat.hs-boot
@@ -1,5 +1,7 @@
 {-# LANGUAGE CPP, KindSignatures #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                       -- in module GHC.Hs.PlaceHolder
 {-# LANGUAGE ConstraintKinds #-}
@@ -9,10 +11,11 @@
 module GHC.Hs.Pat where
 
 import Outputable
-import GHC.Hs.Extension ( OutputableBndrId, GhcPass )
+import GHC.Hs.Extension ( OutputableBndrId, GhcPass, Loc )
 
 type role Pat nominal
 data Pat (i :: *)
-type LPat i = Pat i
+type LPat i = Pat (Loc i)
 
-instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p)
+instance OutputableBndrId (GhcPass p) => Outputable (LPat (GhcPass p))
+instance OutputableBndrId (GhcPass p) => Outputable (Pat (GhcPass p))
diff --git a/compiler/GHC/HsToCore/PmCheck.hs b/compiler/GHC/HsToCore/PmCheck.hs
index 5e8a80fdcc..c37d609ff1 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,9 @@ translatePat fam_insts x pat = case pat of
   -- Not supposed to happen
   ConPatIn  {} -> panic "Check.translatePat: ConPatIn"
   SplicePat {} -> panic "Check.translatePat: SplicePat"
+  -- XPat should only occur in an LPat. We strip it off by calling unLoc in
+  -- translateLPat.
+  XPat      {} -> panic "Check.translatePat: XPat"
 
 -- | 'translatePat', but also select and return a new match var.
 translatePatV :: FamInstEnvs -> Pat GhcTc -> DsM (Id, GrdVec)
@@ -598,12 +599,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 +645,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 +675,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 +714,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/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 8d6ddf03e1..1cf981cddd 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -930,7 +930,7 @@ dsDo stmts
                  (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
                do_arg (XApplicativeArg nec) = noExtCon nec
 
-               arg_tys = map hsPatType pats
+               arg_tys = map hsLPatType pats
 
            ; rhss' <- sequence rhss
 
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 52f8c59a4d..a15d612998 100644
--- a/compiler/hieFile/HieAst.hs
+++ b/compiler/hieFile/HieAst.hs
@@ -478,7 +478,7 @@ instance HasLoc (HsDataDefn GhcRn) where
     -- Most probably the rest will be unhelpful anyway
   loc _ = noSrcSpan
 
-instance HasLoc (Pat (GhcPass a)) where
+instance HasLoc (LPat (GhcPass a)) where
   loc (dL -> L l _) = l
 
 {- Note [Real DataCon Name]
diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs
index 34f1a1fb37..d9c2136aca 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
@@ -257,7 +257,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 3e5f7dc1fe..73cac82cc1 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,
@@ -96,12 +96,16 @@ import Control.Arrow ( second )
 
 -}
 
+hsLPatType :: LPat GhcTc -> Type
+hsLPatType (XPat (dL->L _ p)) = hsPatType p
+hsLPatType p                  = pprPanic "hsLPatType" (ppr 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,7 +122,7 @@ 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{}                        = panic "hsPatType: XPat"
 hsPatType ConPatIn{}                    = panic "hsPatType: ConPatIn"
 hsPatType SplicePat{}                   = panic "hsPatType: SplicePat"
 
diff --git a/utils/haddock b/utils/haddock
-Subproject a7c42a29f7c33f5fdbb04acc3866ec907c2e00f
+Subproject a861e78cdcf854dd3886938f9d0394de78c3e22