EPA: Get rid of bare SrcSpan's in the ParsedSource

The ghc-exactPrint library has had to re-introduce the relatavise
phase.

This is needed if you change the length of an identifier and want the
layout to be preserved afterwards.

It is not possible to relatavise a bare SrcSpan, so introduce `SrcAnn
NoEpAnns` for them instead.

Updates haddock submodule.

6 files changed, 35 insertions, 33 deletions

diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 1e4c43cf7d..b85cee2a51 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -1181,8 +1181,8 @@ type AnnoBody body
     , Anno [LocatedA (Match GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL
     , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
     , Anno (Match GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
-    , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcSpan
-    , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ SrcSpan
+    , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns
+    , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ SrcAnn NoEpAnns
     , Outputable (body GhcPs)
     )
 
@@ -1254,7 +1254,7 @@ rnGRHS :: AnnoBody body
        -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
        -> LGRHS GhcPs (LocatedA (body GhcPs))
        -> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), FreeVars)
-rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)
+rnGRHS ctxt rnBody = wrapLocFstMA (rnGRHS' ctxt rnBody)
 
 rnGRHS' :: HsMatchContext GhcRn
         -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 35129a55cd..d02d04515e 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -721,7 +721,7 @@ See #18151.
 ************************************************************************
 -}
 
-rnDotFieldOcc :: Located (DotFieldOcc GhcPs) -> Located (DotFieldOcc GhcRn)
+rnDotFieldOcc :: LocatedAn NoEpAnns (DotFieldOcc GhcPs) -> LocatedAn NoEpAnns (DotFieldOcc GhcRn)
 rnDotFieldOcc (L l (DotFieldOcc x label)) = L l (DotFieldOcc x label)
 
 rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn
@@ -743,7 +743,7 @@ rnCmdArgs (arg:args)
        ; return (arg':args', fvArg `plusFV` fvArgs) }
 
 rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
-rnCmdTop = wrapLocFstM rnCmdTop'
+rnCmdTop = wrapLocFstMA rnCmdTop'
  where
   rnCmdTop' :: HsCmdTop GhcPs -> RnM (HsCmdTop GhcRn, FreeVars)
   rnCmdTop' (HsCmdTop _ cmd)
@@ -888,7 +888,7 @@ methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)
 
 -------------------------------------------------
 
-methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
+methodNamesGRHS :: LocatedAn NoEpAnns (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
 methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs
 
 ---------------------------------------------------
@@ -2621,33 +2621,33 @@ mkExpandedExpr a b = XExpr (HsExpanded a b)
 
 -- mkGetField arg field calcuates a get_field @field arg expression.
 -- e.g. z.x = mkGetField z x = get_field @x z
-mkGetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn
+mkGetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
 mkGetField get_field arg field = unLoc (head $ mkGet get_field [arg] field)
 
 -- mkSetField a field b calculates a set_field @field expression.
 -- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' on a to b").
-mkSetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn
+mkSetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn
 mkSetField set_field a (L _ field) b =
   genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field)  a) b
 
-mkGet :: Name -> [LHsExpr GhcRn] -> Located FieldLabelString -> [LHsExpr GhcRn]
+mkGet :: Name -> [LHsExpr GhcRn] -> LocatedAn NoEpAnns FieldLabelString -> [LHsExpr GhcRn]
 mkGet get_field l@(r : _) (L _ field) =
   wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) : l
 mkGet _ [] _ = panic "mkGet : The impossible has happened!"
 
-mkSet :: Name -> LHsExpr GhcRn -> (Located FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn
+mkSet :: Name -> LHsExpr GhcRn -> (LocatedAn NoEpAnns FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn
 mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc)
 
 -- mkProjection fields calculates a projection.
 -- e.g. .x = mkProjection [x] = getField @"x"
 --      .x.y = mkProjection [.x, .y] = (.y) . (.x) = getField @"y" . getField @"x"
-mkProjection :: Name -> Name -> [Located FieldLabelString] -> HsExpr GhcRn
+mkProjection :: Name -> Name -> [LocatedAn NoEpAnns FieldLabelString] -> HsExpr GhcRn
 mkProjection getFieldName circName (field : fields) = foldl' f (proj field) fields
   where
-    f :: HsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn
+    f :: HsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
     f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc]
 
-    proj :: Located FieldLabelString -> HsExpr GhcRn
+    proj :: LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
     proj (L _ f) = genHsVar getFieldName `genAppType` genHsTyLit f
 mkProjection _ _ [] = panic "mkProjection: The impossible happened"
 
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index 674cfe6198..1340993084 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -1469,7 +1469,7 @@ mkOpFormRn a1@(L loc
   | associate_right
   = do new_c <- mkOpFormRn a12 op2 fix2 a2
        return (HsCmdArrForm noExtField op1 f (Just fix1)
-               [a11, L loc (HsCmdTop [] (L (noAnnSrcSpan loc) new_c))])
+               [a11, L loc (HsCmdTop [] (L (l2l loc) new_c))])
         -- TODO: locs are wrong
   where
     (nofix_error, associate_right) = compareFixity fix1 fix2
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index c99098963b..bdb5a29e55 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -1996,7 +1996,7 @@ rnLHsDerivingClause doc
                               , deriv_clause_tys = dct }))
   = do { (dcs', dct', fvs)
            <- rnLDerivStrategy doc dcs $ rn_deriv_clause_tys dct
-       ; warnNoDerivStrat dcs' loc
+       ; warnNoDerivStrat dcs' (locA loc)
        ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField
                                         , deriv_clause_strategy = dcs'
                                         , deriv_clause_tys = dct' })
@@ -2034,7 +2034,7 @@ rnLDerivStrategy doc mds thing_inside
   = case mds of
       Nothing -> boring_case Nothing
       Just (L loc ds) ->
-        setSrcSpan loc $ do
+        setSrcSpanA loc $ do
           (ds', thing, fvs) <- rn_deriv_strat ds
           pure (Just (L loc ds'), thing, fvs)
   where
@@ -2117,7 +2117,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
        ; ((tyvars', res_sig', injectivity'), fv1) <-
             bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' _ ->
             do { let rn_sig = rnFamResultSig doc
-               ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
+               ; (res_sig', fv_kind) <- wrapLocFstMA rn_sig res_sig
                ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
                                           injectivity
                ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
@@ -2225,7 +2225,9 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
              -- e.g.   type family F a = (r::*) | r -> a
              do { injFrom' <- rnLTyVar injFrom
                 ; injTo'   <- mapM rnLTyVar injTo
-                ; return $ L srcSpan (InjectivityAnn x injFrom' injTo') }
+                -- Note: srcSpan is unchanged, but typechecker gets
+                -- confused, l2l call makes it happy
+                ; return $ L (l2l srcSpan) (InjectivityAnn x injFrom' injTo') }
 
    ; let tvNames  = Set.fromList $ hsAllLTyVarNames tvBndrs
          resName  = hsLTyVarName resTv
@@ -2246,7 +2248,7 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
 
    ; when (noRnErrors && not (Set.null rhsValid)) $
       do { let errorVars = Set.toList rhsValid
-         ; addErrAt srcSpan $ TcRnUnknownMessage $ mkPlainError noHints $
+         ; addErrAt (locA srcSpan) $ TcRnUnknownMessage $ mkPlainError noHints $
                         ( hsep
                         [ text "Unknown type variable" <> plural errorVars
                         , text "on the RHS of injectivity condition:"
@@ -2263,7 +2265,7 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
 -- So we rename injectivity annotation like we normally would except that
 -- this time we expect "result" to be reported not in scope by rnLTyVar.
 rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn x injFrom injTo)) =
-   setSrcSpan srcSpan $ do
+   setSrcSpanA srcSpan $ do
    (injDecl', _) <- askNoErrs $ do
      injFrom' <- rnLTyVar injFrom
      injTo'   <- mapM rnLTyVar injTo
@@ -2444,7 +2446,7 @@ extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do {
                                        , psb_args = RecCon as }))) <- bind
       = do
           bnd_name <- newTopSrcBinder (L (l2l bind_loc) n)
-          let field_occs = map ((\ f -> L (getLocA (foLabel f)) f) . recordPatSynField) as
+          let field_occs = map ((\ f -> L (noAnnSrcSpan $ getLocA (foLabel f)) f) . recordPatSynField) as
           flds <- mapM (newRecordSelector dup_fields_ok has_sel [bnd_name]) field_occs
           return ((bnd_name, flds): names)
       | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 67350973b5..768e43fca1 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -1028,7 +1028,7 @@ getLocalNonValBinders fixity_env
 newRecordSelector :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel
 newRecordSelector _ _ [] _ = error "newRecordSelector: datatype has no constructors!"
 newRecordSelector dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld)))
-  = do { selName <- newTopSrcBinder $ L (noAnnSrcSpan loc) $ field
+  = do { selName <- newTopSrcBinder $ L (l2l loc) $ field
        ; return $ FieldLabel { flLabel = fieldLabelString
                              , flHasDuplicateRecordFields = dup_fields_ok
                              , flHasFieldSelector = has_sel
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 534b03e602..a011b709cf 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -516,7 +516,7 @@ rnPatAndThen mk (LitPat x lit)
   = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)
        ; if ovlStr
          then rnPatAndThen mk
-                           (mkNPat (noLoc (mkHsIsString src s))
+                           (mkNPat (noLocA (mkHsIsString src s))
                                       Nothing noAnn)
          else normal_lit }
   | otherwise = normal_lit
@@ -778,12 +778,12 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
                                   (L loc (FieldOcc _ (L ll lbl)))
                               , hfbRHS = arg
                               , hfbPun      = pun }))
-      = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl
+      = do { sel <- setSrcSpanA loc $ lookupRecFieldOcc parent lbl
            ; arg' <- if pun
-                     then do { checkErr pun_ok (TcRnIllegalFieldPunning (L loc lbl))
+                     then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl))
                                -- Discard any module qualifier (#11662)
                              ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
-                             ; return (L (noAnnSrcSpan loc) (mk_arg loc arg_rdr)) }
+                             ; return (L (l2l loc) (mk_arg (locA loc) arg_rdr)) }
                      else return arg
            ; return (L l (HsFieldBind
                              { hfbAnn = noAnn
@@ -833,7 +833,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
            ; return [ L (noAnnSrcSpan loc) (HsFieldBind
                         { hfbAnn = noAnn
                         , hfbLHS
-                           = L loc (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr))
+                           = L (noAnnSrcSpan loc) (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr))
                         , hfbRHS = L locn (mk_arg loc arg_rdr)
                         , hfbPun      = False })
                     | fl <- dot_dot_fields
@@ -881,23 +881,23 @@ rnHsRecUpdFields flds
                                                   , hfbRHS = arg
                                                   , hfbPun      = pun }))
       = do { let lbl = rdrNameAmbiguousFieldOcc f
-           ; mb_sel <- setSrcSpan loc $
+           ; mb_sel <- setSrcSpanA loc $
                       -- Defer renaming of overloaded fields to the typechecker
                       -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head
                       lookupRecFieldOcc_update dup_fields_ok lbl
            ; arg' <- if pun
-                     then do { checkErr pun_ok (TcRnIllegalFieldPunning (L loc lbl))
+                     then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl))
                                -- Discard any module qualifier (#11662)
                              ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
-                             ; return (L (noAnnSrcSpan loc) (HsVar noExtField
-                                              (L (noAnnSrcSpan loc) arg_rdr))) }
+                             ; return (L (l2l loc) (HsVar noExtField
+                                              (L (l2l loc) arg_rdr))) }
                      else return arg
            ; (arg'', fvs) <- rnLExpr arg'
 
            ; let (lbl', fvs') = case mb_sel of
                    UnambiguousGre gname -> let sel_name = greNameMangledName gname
-                                           in (Unambiguous sel_name (L (noAnnSrcSpan loc) lbl), fvs `addOneFV` sel_name)
-                   AmbiguousFields       -> (Ambiguous   noExtField (L (noAnnSrcSpan loc) lbl), fvs)
+                                           in (Unambiguous sel_name (L (l2l loc) lbl), fvs `addOneFV` sel_name)
+                   AmbiguousFields       -> (Ambiguous   noExtField (L (l2l loc) lbl), fvs)
 
            ; return (L l (HsFieldBind { hfbAnn = noAnn
                                       , hfbLHS = L loc lbl'