[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)`)

1 files changed, 17 insertions, 0 deletions

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