Bespoke TokenLocation data type

The EpaAnnCO we were using contained an Anchor instead of EpaLocation,
making it harder to work with.

At the same time, using EpaLocation by itself isn't possible either,
as we may have tokens without location information.

Hence the new data type:
	data TokenLocation = NoTokenLoc
	                   | TokenLoc !EpaLocation

4 files changed, 36 insertions, 12 deletions

diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index 841604ecb9..ce28e0355d 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -236,12 +236,12 @@ pprIfTc :: forall p. IsPass p => (p ~ 'Typechecked => SDoc) -> SDoc
 pprIfTc pp = case ghcPass @p of GhcTc -> pp
                                 _     -> empty
 
-type instance Anno (HsToken tok) = EpAnnCO
+type instance Anno (HsToken tok) = TokenLocation
 
-noHsTok :: GenLocated (EpAnn a) (HsToken tok)
-noHsTok = L noAnn HsTok
+noHsTok :: GenLocated TokenLocation (HsToken tok)
+noHsTok = L NoTokenLoc HsTok
 
-type instance Anno (HsUniToken tok utok) = EpAnnCO
+type instance Anno (HsUniToken tok utok) = TokenLocation
 
-noHsUniTok :: GenLocated (EpAnn a) (HsUniToken tok utok)
-noHsUniTok = L noAnn HsNormalTok
+noHsUniTok :: GenLocated TokenLocation (HsUniToken tok utok)
+noHsUniTok = L NoTokenLoc HsNormalTok
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 6d0a276ab7..0cc1bc732a 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -4354,11 +4354,11 @@ listAsAnchor [] = spanAsAnchor noSrcSpan
 listAsAnchor (L l _:_) = spanAsAnchor (locA l)
 
 hsTok :: Located Token -> LHsToken tok GhcPs
-hsTok (L l _) = L (EpAnn (spanAsAnchor l) NoEpAnns emptyComments) HsTok
+hsTok (L l _) = L (mkTokenLocation l) HsTok
 
 hsUniTok :: Located Token -> LHsUniToken tok utok GhcPs
 hsUniTok t@(L l _) =
-  L (EpAnn (spanAsAnchor l) NoEpAnns emptyComments)
+  L (mkTokenLocation l)
     (if isUnicode t then HsUnicodeTok else HsNormalTok)
 
 -- -------------------------------------
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index a914a14b71..b414e70be5 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -14,6 +14,7 @@ module GHC.Parser.Annotation (
   -- * In-tree Exact Print Annotations
   AddEpAnn(..),
   EpaLocation(..), epaLocationRealSrcSpan, epaLocationFromSrcAnn,
+  TokenLocation(..),
   DeltaPos(..), deltaPos, getDeltaLine,
 
   EpAnn(..), Anchor(..), AnchorOperation(..),
@@ -405,6 +406,11 @@ data EpaLocation = EpaSpan RealSrcSpan
                  | EpaDelta DeltaPos
                deriving (Data,Show,Eq,Ord)
 
+-- | Tokens embedded in the AST have an EpaLocation, unless they come from
+-- generated code (e.g. by TH).
+data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation
+               deriving (Data,Show,Eq,Ord)
+
 -- | Spacing between output items when exact printing.  It captures
 -- the spacing from the current print position on the page to the
 -- position required for the thing about to be printed.  This is
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 688464dd9d..55b3c0d8a9 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -74,6 +74,9 @@ module GHC.Parser.PostProcess (
         UnpackednessPragma(..),
         mkMultTy,
 
+        -- Token location
+        mkTokenLocation,
+
         -- Help with processing exports
         ImpExpSubSpec(..),
         ImpExpQcSpec(..),
@@ -2994,13 +2997,28 @@ mkLHsOpTy x op y =
 mkMultTy :: LHsToken "%" GhcPs -> LHsType GhcPs -> LHsUniToken "->" "→" GhcPs -> HsArrow GhcPs
 mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1))) arr
   -- See #18888 for the use of (SourceText "1") above
-  = HsLinearArrow (HsPct1 (L (getLoc pct Semi.<> locOf1) HsTok) arr)
+  = HsLinearArrow (HsPct1 (L locOfPct1 HsTok) arr)
   where
-    -- The location of "1" in "%1".
-    locOf1 :: EpAnn NoEpAnns
-    locOf1 = EpAnn (spanAsAnchor (locA (getLoc t))) NoEpAnns emptyComments
+    -- The location of "%" combined with the location of "1".
+    locOfPct1 :: TokenLocation
+    locOfPct1 = token_location_widenR (getLoc pct) (locA (getLoc t))
 mkMultTy pct t arr = HsExplicitMult pct t arr
 
+mkTokenLocation :: SrcSpan -> TokenLocation
+mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc
+mkTokenLocation (RealSrcSpan r _)  = TokenLoc (EpaSpan r)
+
+-- Precondition: the TokenLocation has EpaSpan, never EpaDelta.
+token_location_widenR :: TokenLocation -> SrcSpan -> TokenLocation
+token_location_widenR NoTokenLoc _ = NoTokenLoc
+token_location_widenR tl (UnhelpfulSpan _) = tl
+token_location_widenR (TokenLoc (EpaSpan r1)) (RealSrcSpan r2 _) =
+                      (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2)))
+token_location_widenR (TokenLoc (EpaDelta _)) _ =
+  -- Never happens because the parser does not produce EpaDelta.
+  panic "token_location_widenR: EpaDelta"
+
+
 -----------------------------------------------------------------------------
 -- Token symbols