[TTG: Handling Source Locations] Foundation and Pat

Trac Issues #15495

This patch removes the ping-pong style from HsPat (only, for now), using the plan laid out at https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow/HandlingSourceLocations (solution A).
- the class `HasSrcSpan`, and its functions (e.g., `cL` and `dL`), are introduced
- some instances of `HasSrcSpan` are introduced
- some constructors `L` are replaced with `cL`
- some patterns `L` are replaced with `dL->L` view pattern
- some type annotation are necessarily updated (e.g., `Pat p` --> `Pat (GhcPass p)`)

7 files changed, 75 insertions, 36 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
index 0ecf7109..a9ffc36e 100644
--- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
+++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Haddock.Backends.Hyperlinker.Ast (enrich) where
 
@@ -80,13 +81,16 @@ variables =
     everythingInRenamedSource (var `Syb.combine` rec)
   where
     var term = case cast term of
-        (Just ((GHC.L sspan (GHC.HsVar _ name)) :: GHC.LHsExpr GHC.GhcRn)) ->
+        (Just ((GHC.dL->GHC.L sspan (GHC.HsVar _ name))
+               :: GHC.LHsExpr GHC.GhcRn)) ->
             pure (sspan, RtkVar (GHC.unLoc name))
-        (Just (GHC.L _ (GHC.RecordCon _ (GHC.L sspan name) _))) ->
+        (Just (GHC.dL->GHC.L _ (GHC.RecordCon _
+                                (GHC.dL->GHC.L sspan name) _))) ->
             pure (sspan, RtkVar name)
         _ -> empty
     rec term = case cast term of
-        Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.GhcRn) _) ->
+        Just (GHC.HsRecField (GHC.dL->GHC.L sspan name)
+              (_ :: GHC.LHsExpr GHC.GhcRn) _) ->
             pure (sspan, RtkVar name)
         _ -> empty
 
@@ -96,9 +100,11 @@ types = everythingInRenamedSource ty
   where
     ty :: forall a. Data a => a -> [(GHC.SrcSpan, TokenDetails)]
     ty term = case cast term of
-        (Just ((GHC.L sspan (GHC.HsTyVar _ _ name)) :: GHC.LHsType GHC.GhcRn)) ->
+        (Just ((GHC.dL->GHC.L sspan (GHC.HsTyVar _ _ name))
+               :: GHC.LHsType GHC.GhcRn)) ->
             pure (sspan, RtkType (GHC.unLoc name))
-        (Just ((GHC.L sspan (GHC.HsOpTy _ l name r)) :: GHC.LHsType GHC.GhcRn)) ->
+        (Just ((GHC.dL->GHC.L sspan (GHC.HsOpTy _ l name r))
+               :: GHC.LHsType GHC.GhcRn)) ->
             (sspan, RtkType (GHC.unLoc name)):(ty l ++ ty r)
         _ -> empty
 
@@ -113,30 +119,38 @@ binds = everythingInRenamedSource
       (fun `Syb.combine` pat `Syb.combine` tvar)
   where
     fun term = case cast term of
-        (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn)) ->
+        (Just (GHC.FunBind _ (GHC.dL->GHC.L sspan name) _ _ _
+               :: GHC.HsBind GHC.GhcRn)) ->
             pure (sspan, RtkBind name)
-        (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) args _ _))) ->
-            pure (sspan, RtkBind name) ++ everythingInRenamedSource patsyn_binds args
+        (Just (GHC.PatSynBind _
+               (GHC.PSB _ (GHC.dL->GHC.L sspan name) args _ _))) ->
+            pure (sspan, RtkBind name)
+            ++ everythingInRenamedSource patsyn_binds args
         _ -> empty
     patsyn_binds term = case cast term of
-        (Just (GHC.L sspan (name :: GHC.Name))) -> pure (sspan, RtkVar name)
+        (Just (GHC.L sspan (name :: GHC.Name))) ->
+          pure (sspan, RtkVar name)
         _ -> empty
     pat term = case cast term of
-        (Just ((GHC.L sspan (GHC.VarPat _ name)) :: GHC.LPat GHC.GhcRn)) ->
+        (Just ((GHC.dL->GHC.L sspan (GHC.VarPat _ name))
+               :: GHC.LPat GHC.GhcRn)) ->
             pure (sspan, RtkBind (GHC.unLoc name))
-        (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) ->
+        (Just (GHC.dL->GHC.L _
+                (GHC.ConPatIn (GHC.dL->GHC.L sspan name) recs))) ->
             [(sspan, RtkVar name)] ++ everythingInRenamedSource rec recs
-        (Just (GHC.L _ (GHC.AsPat _ (GHC.L sspan name) _))) ->
+        (Just (GHC.dL->GHC.L _ (GHC.AsPat _ (GHC.dL->GHC.L sspan name) _))) ->
             pure (sspan, RtkBind name)
         _ -> empty
     rec term = case cast term of
-        (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.GhcRn) _)) ->
+        (Just (GHC.HsRecField (GHC.dL->GHC.L sspan name)
+               (_ :: GHC.LPat GHC.GhcRn) _)) ->
             pure (sspan, RtkVar name)
         _ -> empty
     tvar term = case cast term of
-        (Just ((GHC.L sspan (GHC.UserTyVar _ name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) ->
+        (Just ((GHC.dL->GHC.L sspan (GHC.UserTyVar _ name))
+               :: GHC.LHsTyVarBndr GHC.GhcRn)) ->
             pure (sspan, RtkBind (GHC.unLoc name))
-        (Just (GHC.L _ (GHC.KindedTyVar _ (GHC.L sspan name) _))) ->
+        (Just (GHC.dL->GHC.L _ (GHC.KindedTyVar _ (GHC.dL->GHC.L sspan name) _))) ->
             pure (sspan, RtkBind name)
         _ -> empty
 
@@ -149,7 +163,7 @@ decls (group, _, _, _) = concatMap ($ group)
     , everythingInRenamedSource (con `Syb.combine` ins)
     ]
   where
-    typ (GHC.L _ t) = case t of
+    typ (GHC.dL->GHC.L _ t) = case t of
         GHC.DataDecl { tcdLName = name } -> pure . decl $ name
         GHC.SynDecl _ name _ _ _ -> pure . decl $ name
         GHC.FamDecl _ fam -> pure . decl $ GHC.fdLName fam
@@ -159,9 +173,10 @@ decls (group, _, _, _) = concatMap ($ group)
             ++ concatMap tyfam tcdATs
         GHC.XTyClDecl {} -> GHC.panic "haddock:decls"
     fun term = case cast term of
-        (Just (GHC.FunBind _ (GHC.L sspan name) _ _ _ :: GHC.HsBind GHC.GhcRn))
+        (Just (GHC.FunBind _ (GHC.dL->GHC.L sspan name) _ _ _
+               :: GHC.HsBind GHC.GhcRn))
             | GHC.isExternalName name -> pure (sspan, RtkDecl name)
-        (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.L sspan name) _ _ _)))
+        (Just (GHC.PatSynBind _ (GHC.PSB _ (GHC.dL->GHC.L sspan name) _ _ _)))
             | GHC.isExternalName name -> pure (sspan, RtkDecl name)
         _ -> empty
     con term = case cast term of
@@ -182,18 +197,20 @@ decls (group, _, _, _) = concatMap ($ group)
         Nothing -> empty
     fix term = case cast term of
         Just ((GHC.FixitySig _ names _) :: GHC.FixitySig GHC.GhcRn)
-          -> map (\(GHC.L sspan x) -> (sspan, RtkVar x)) names
+          -> map (\(GHC.dL->GHC.L sspan x) -> (sspan, RtkVar x)) names
         Just ((GHC.XFixitySig {}) :: GHC.FixitySig GHC.GhcRn)
           -> GHC.panic "haddock:decls"
         Nothing -> empty
-    tyfam (GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName]
-    tyfam (GHC.L _ (GHC.XFamilyDecl {})) = GHC.panic "haddock:dels"
-    sig (GHC.L _ (GHC.TypeSig _ names _)) = map decl names
-    sig (GHC.L _ (GHC.PatSynSig _ names _)) = map decl names
-    sig (GHC.L _ (GHC.ClassOpSig _ _ names _)) = map decl names
+    tyfam (GHC.dL->GHC.L _ (GHC.FamilyDecl{..})) = [decl fdLName]
+    tyfam (GHC.dL->GHC.L _ (GHC.XFamilyDecl {})) = GHC.panic "haddock:dels"
+    tyfam _ = GHC.panic "tyfam: Impossible Match"
+
+    sig (GHC.dL->GHC.L _ (GHC.TypeSig _ names _)) = map decl names
+    sig (GHC.dL->GHC.L _ (GHC.PatSynSig _ names _)) = map decl names
+    sig (GHC.dL->GHC.L _ (GHC.ClassOpSig _ _ names _)) = map decl names
     sig _ = []
-    decl (GHC.L sspan name) = (sspan, RtkDecl name)
-    tyref (GHC.L sspan name) = (sspan, RtkType name)
+    decl (GHC.dL->GHC.L sspan name) = (sspan, RtkDecl name)
+    tyref (GHC.dL->GHC.L sspan name) = (sspan, RtkType name)
 
 -- | Obtain details map for import declarations.
 --
@@ -204,16 +221,17 @@ imports src@(_, imps, _, _) =
     everythingInRenamedSource ie src ++ mapMaybe (imp . GHC.unLoc) imps
   where
     ie term = case cast term of
-        (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v
+        (Just ((GHC.IEVar _ v) :: GHC.IE GHC.GhcRn)) -> pure $ var
+          $ GHC.ieLWrappedName v
         (Just (GHC.IEThingAbs _ t)) -> pure $ typ $ GHC.ieLWrappedName t
         (Just (GHC.IEThingAll _ t)) -> pure $ typ $ GHC.ieLWrappedName t
         (Just (GHC.IEThingWith _ t _ vs _fls)) ->
           [typ $ GHC.ieLWrappedName t] ++ map (var . GHC.ieLWrappedName) vs
         (Just (GHC.IEModuleContents _ m)) -> pure $ modu m
         _ -> empty
-    typ (GHC.L sspan name) = (sspan, RtkType name)
-    var (GHC.L sspan name) = (sspan, RtkVar name)
-    modu (GHC.L sspan name) = (sspan, RtkModule name)
+    typ (GHC.dL->GHC.L sspan name) = (sspan, RtkType name)
+    var (GHC.dL->GHC.L sspan name) = (sspan, RtkVar name)
+    modu (GHC.dL->GHC.L sspan name) = (sspan, RtkModule name)
     imp idecl
       | not . GHC.ideclImplicit $ idecl = Just (modu (GHC.ideclName idecl))
       | otherwise = Nothing
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index 22cb247f..b66116bb 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -1,5 +1,7 @@
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Backends.LaTeX
diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs
index db29c7cf..da8f7a53 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml.hs
@@ -397,11 +397,11 @@ ppJsonIndex odir maybe_source_url maybe_wiki_url unicode pkg qual_opt ifaces = d
       where
         names = exportName item ++ exportSubs item
 
-    exportSubs :: ExportItem name -> [IdP name]
+    exportSubs :: ExportItem DocNameI -> [IdP DocNameI]
     exportSubs ExportDecl { expItemSubDocs } = map fst expItemSubDocs
     exportSubs _ = []
 
-    exportName :: ExportItem name -> [IdP name]
+    exportName :: ExportItem DocNameI -> [IdP DocNameI]
     exportName ExportDecl { expItemDecl } = getMainDeclBinder (unLoc expItemDecl)
     exportName ExportNoDecl { expItemName } = [expItemName]
     exportName _ = []
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index ec8de12a..395c0837 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE TransformListComp #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE TypeFamilies #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Backends.Html.Decl
@@ -1215,4 +1217,3 @@ ppr_mono_ty (HsTyLit _ n) _ _ _ = ppr_tylit n
 ppr_tylit :: HsTyLit -> Html
 ppr_tylit (HsNumTy _ n) = toHtml (show n)
 ppr_tylit (HsStrTy _ s) = toHtml (show s)
-
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index e7d80969..cfb91f93 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE BangPatterns, FlexibleInstances, ViewPatterns #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_HADDOCK hide #-}
 -----------------------------------------------------------------------------
@@ -48,7 +49,8 @@ isConSym :: OccName -> Bool
 isConSym = isLexConSym . occNameFS
 
 
-getMainDeclBinder :: HsDecl name -> [IdP name]
+getMainDeclBinder :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>
+                     HsDecl p -> [IdP p]
 getMainDeclBinder (TyClD _ d) = [tcdName d]
 getMainDeclBinder (ValD _ d) =
   case collectHsBindBinders d of
@@ -434,5 +436,3 @@ setStubDir    f d = d{ stubDir    = Just f
   -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
   -- \#included from the .hc file when compiling with -fvia-C.
 setOutputDir  f = setObjectDir f . setHiDir f . setStubDir f
-
-
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 42281470..c6160b2b 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
 ----------------------------------------------------------------------------
 -- |
 -- Module      :  Haddock.Interface.Rename
diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs
index ea8ffe5f..7b3c90a2 100644
--- a/haddock-api/src/Haddock/Types.hs
+++ b/haddock-api/src/Haddock/Types.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving, TypeFamilies, RecordWildCards #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+{-# LANGUAGE FlexibleInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -----------------------------------------------------------------------------
@@ -742,3 +743,19 @@ type instance XHsWC      DocNameI _ = NoExt
 type instance XHsQTvs        DocNameI = NoExt
 type instance XConDeclField  DocNameI = NoExt
 
+type instance XXPat DocNameI = Located (Pat DocNameI)
+
+type instance SrcSpanLess (LPat DocNameI) = Pat DocNameI
+instance HasSrcSpan (LPat DocNameI) 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 DocNameI -> Pat DocNameI
+stripSrcSpanPat (XPat (L _ p)) = stripSrcSpanPat p
+stripSrcSpanPat p              = p