[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] 3 commits: EPA: Remove LocatedP from OverlapMode

3 Jul 2026


      Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC


Commits:
3555aee5 by Alan Zimmerman at 2026-07-02T23:04:24+01:00
EPA: Remove LocatedP from OverlapMode

- - - - -
b7559a99 by Alan Zimmerman at 2026-07-02T23:04:24+01:00
EPA: Remove LocatedP from CType

- - - - -
cedb075f by Alan Zimmerman at 2026-07-02T23:04:24+01:00
EPA: Remove LocatedP, last use in WarningTxt

- - - - -


18 changed files:

- compiler/GHC/Builtin/Utils.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Decls/Overlap.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Warnings.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/ForeignCall.hs
- compiler/GHC/Unit/Module/Warnings.hs
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs


Changes:

=====================================
compiler/GHC/Builtin/Utils.hs
=====================================
@@ -299,7 +299,7 @@ ghcPrimWarns = WarnSome
   []
   where
     mk_txt msg =
-      DeprecatedTxt NoSourceText [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText msg Nothing) []]
+      DeprecatedTxt (NoSourceText, noAnn) [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText msg Nothing) []]
     mk_decl_dep (occ, msg) = (occ, mk_txt msg)
 
 ghcPrimFixities :: [(OccName,Fixity)]


=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1162,7 +1162,7 @@ cidDeprecation :: forall p. IsPass p
 cidDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)
   where
     decl_deprecation :: GhcPass p  -> ClsInstDecl (GhcPass p)
-                     -> Maybe (LocatedP (WarningTxt (GhcPass p)))
+                     -> Maybe (LocatedA (WarningTxt (GhcPass p)))
     decl_deprecation GhcPs (ClsInstDecl{ cid_ext = (depr, _) } )
       = depr
     decl_deprecation GhcRn (ClsInstDecl{ cid_ext = depr })
@@ -1272,20 +1272,25 @@ ppDerivStrategy mb =
     Nothing       -> empty
     Just (L _ ds) -> ppr ds
 
-ppOverlapPragma :: Maybe (LocatedP (OverlapMode (GhcPass p))) -> SDoc
+ppOverlapPragma :: forall p. IsPass p => Maybe (LocatedA (OverlapMode (GhcPass p))) -> SDoc
 ppOverlapPragma mb =
   case mb of
     Nothing           -> empty
-    Just (L _ (NoOverlap s))    -> maybe_stext s "{-# NO_OVERLAP #-}"
-    Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}"
-    Just (L _ (Overlapping s))  -> maybe_stext s "{-# OVERLAPPING #-}"
-    Just (L _ (Overlaps s))     -> maybe_stext s "{-# OVERLAPS #-}"
-    Just (L _ (Incoherent s))   -> maybe_stext s "{-# INCOHERENT #-}"
-    Just (L _ (NonCanonical s)) -> maybe_stext s "{-# INCOHERENT #-}" -- No surface syntax for NONCANONICAL yet
+    Just (L _ (NoOverlap s))    -> maybe_stext (stext s) "{-# NO_OVERLAP #-}"
+    Just (L _ (Overlappable s)) -> maybe_stext (stext s) "{-# OVERLAPPABLE #-}"
+    Just (L _ (Overlapping s))  -> maybe_stext (stext s) "{-# OVERLAPPING #-}"
+    Just (L _ (Overlaps s))     -> maybe_stext (stext s) "{-# OVERLAPS #-}"
+    Just (L _ (Incoherent s))   -> maybe_stext (stext s) "{-# INCOHERENT #-}"
+    Just (L _ (NonCanonical s)) -> maybe_stext (stext s) "{-# INCOHERENT #-}" -- No surface syntax for NONCANONICAL yet
   where
     maybe_stext NoSourceText     alt = text alt
     maybe_stext (SourceText src) _   = ftext src <+> text "#-}"
 
+    stext :: XOverlapMode (GhcPass p) -> SourceText
+    stext s = case (ghcPass @p, s) of
+                (GhcPs, (s,_)) -> s
+                (GhcRn, (s,_)) -> s
+                (GhcTc, s) -> s
 
 instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where
     ppr (ClsInstD     { cid_inst  = decl }) = ppr decl
@@ -1355,7 +1360,7 @@ derivDeprecation :: forall p. IsPass p
 derivDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)
   where
     decl_deprecation :: GhcPass p  -> DerivDecl (GhcPass p)
-                     -> Maybe (LocatedP (WarningTxt (GhcPass p)))
+                     -> Maybe (LocatedA (WarningTxt (GhcPass p)))
     decl_deprecation GhcPs (DerivDecl{ deriv_ext = (depr, _) })
       = depr
     decl_deprecation GhcRn (DerivDecl{ deriv_ext = (depr, _) })
@@ -1696,7 +1701,7 @@ type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA
 type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO
 type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA
 type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO
-type instance Anno (CType (GhcPass p)) = SrcSpanAnnP
+type instance Anno (CType (GhcPass p)) = SrcSpanAnnA
 type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO
 type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnA
 type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA
@@ -1711,7 +1716,7 @@ type instance Anno (ClsInstDecl (GhcPass p)) = SrcSpanAnnA
 type instance Anno (InstDecl (GhcPass p)) = SrcSpanAnnA
 type instance Anno (DocDecl (GhcPass p)) = SrcSpanAnnA
 type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA
-type instance Anno (OverlapMode (GhcPass p)) = SrcSpanAnnP
+type instance Anno (OverlapMode (GhcPass p)) = SrcSpanAnnA
 type instance Anno (DerivStrategy (GhcPass p)) = EpAnnCO
 type instance Anno (DefaultDecl (GhcPass p)) = SrcSpanAnnA
 type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA


=====================================
compiler/GHC/Hs/Decls/Overlap.hs
=====================================
@@ -31,6 +31,8 @@ import GHC.Prelude
 
 import GHC.Hs.Extension
 
+import GHC.Parser.Annotation ( AnnPragma )
+
 import Language.Haskell.Syntax.Decls.Overlap
 import Language.Haskell.Syntax.Extension
 
@@ -70,11 +72,13 @@ instance NFData OverlapFlag where
 instance Outputable OverlapFlag where
     ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)
 
-type instance XOverlapMode  (GhcPass _) = SourceText
+type instance XOverlapMode  GhcPs = (SourceText, AnnPragma)
+type instance XOverlapMode  GhcRn = (SourceText, AnnPragma)
+type instance XOverlapMode  GhcTc = SourceText
 
 type instance XXOverlapMode (GhcPass _) = DataConCantHappen
 
-instance NFData (OverlapMode (GhcPass p)) where
+instance NFData (OverlapMode GhcTc) where
     rnf = \case
         NoOverlap    s -> rnf s
         Overlappable s -> rnf s
@@ -83,7 +87,7 @@ instance NFData (OverlapMode (GhcPass p)) where
         Incoherent   s -> rnf s
         NonCanonical s -> rnf s
 
-instance Binary (OverlapMode (GhcPass p)) where
+instance Binary (OverlapMode GhcTc) where
     put_ bh = \case
         NoOverlap    s -> putByte bh 0 >> put_ bh s
         Overlaps     s -> putByte bh 1 >> put_ bh s


=====================================
compiler/GHC/Hs/Dump.hs
=====================================
@@ -97,7 +97,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
               `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
               `ext2Q` located
               `extQ` srcSpanAnnA
-              `extQ` srcSpanAnnP
               `extQ` srcSpanAnnN
               `extQ` srcSpanAnnBF
 
@@ -404,9 +403,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
             srcSpanAnnA :: EpAnn [TrailingAnn] -> SDoc
             srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA")
 
-            srcSpanAnnP :: EpAnn AnnPragma -> SDoc
-            srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP")
-
             srcSpanAnnN :: EpAnn NameAnn -> SDoc
             srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")
 


=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1750,7 +1750,7 @@ instance ToHie (RScoped (LocatedAn NoEpAnns (DerivStrategy GhcRn))) where
       NewtypeStrategy _ -> []
       ViaStrategy s -> [ toHie (TS (ResolvedScopes [sc]) s) ]
 
-instance ToHie (LocatedP (OverlapMode GhcRn)) where
+instance ToHie (LocatedA (OverlapMode GhcRn)) where
   toHie (L span _) = locOnly (locA span)
 
 instance ToHie (LocatedA (ConDecl GhcRn)) where


=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -83,7 +83,7 @@ import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag )
 import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..))
 import GHC.Builtin.Types ( constraintKindTyConName )
 import GHC.Stg.EnforceEpt.TagSig
-import GHC.Parser.Annotation (noLocA)
+import GHC.Parser.Annotation (noLocA, noAnn)
 import GHC.Hs.Extension ( GhcPass, GhcRn, GhcTc )
 import GHC.Hs.Decls.Overlap ( OverlapFlag )
 import GHC.Hs.Doc ( WithHsDocIdentifiers(..) )
@@ -664,8 +664,8 @@ fromIfaceWarnings = \case
 
 fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn
 fromIfaceWarningTxt = \case
-    IfWarningTxt src mb_cat strs -> WarningTxt src (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs)
-    IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs)
+    IfWarningTxt src mb_cat strs -> WarningTxt (src, noAnn) (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs)
+    IfDeprecatedTxt src strs -> DeprecatedTxt (src, noAnn) (noLocA <$> map fromIfaceStringLiteralWithNames strs)
 
 fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn
 fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLoc names)


=====================================
compiler/GHC/Iface/Warnings.hs
=====================================
@@ -23,12 +23,11 @@ toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds'
     ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds]
 
 toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt
-toIfaceWarningTxt (WarningTxt src mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs)
-toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs)
+toIfaceWarningTxt (WarningTxt (src, _) mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs)
+toIfaceWarningTxt (DeprecatedTxt (src, _) strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs)
 
 toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName])
 toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names)
 
 toIfaceStringLiteral :: StringLiteral -> IfaceStringLiteral
 toIfaceStringLiteral (StringLiteral sl fs _) = IfStringLiteral sl fs
-


=====================================
compiler/GHC/Parser.y
=====================================
@@ -1469,15 +1469,15 @@ inst_decl :: { LInstDecl GhcPs }
                                    (fmap reverse $7)
                             (AnnDataDefn [] [] NoEpTok tnewtype tdata (epTok $2) dcolon twhere oc cc NoEpTok)}}
 
-overlap_pragma :: { Maybe (LocatedP (OverlapMode GhcPs)) }
-  : '{-# OVERLAPPABLE'    '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))
-                                       (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) }
-  | '{-# OVERLAPPING'     '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))
-                                       (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) }
-  | '{-# OVERLAPS'        '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))
-                                       (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) }
-  | '{-# INCOHERENT'      '#-}' {% fmap Just $ amsr (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))
-                                       (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) }
+overlap_pragma :: { Maybe (LocatedA (OverlapMode GhcPs)) }
+  : '{-# OVERLAPPABLE'    '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1,
+                                       AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) }
+  | '{-# OVERLAPPING'     '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1,
+                                       AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) }
+  | '{-# OVERLAPS'        '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1,
+                                       AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) }
+  | '{-# INCOHERENT'      '#-}' {% fmap Just $ amsA' (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1,
+                                       AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) }
   | {- empty -}                 { Nothing }
 
 deriv_strategy_no_via :: { LDerivStrategy GhcPs }
@@ -1705,15 +1705,17 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs
         | type                      { sL1 $1 (Nothing, mkHsOuterImplicit, $1) }
 
 
-capi_ctype :: { Maybe (LocatedP (CType GhcPs)) }
+capi_ctype :: { Maybe (LocatedA (CType GhcPs)) }
 capi_ctype : '{-# CTYPE' STRING STRING '#-}'
-                       {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) (Just (Header (getSTRINGs $2) (getSTRING $2)))
-                                        (getSTRING $3)))
-                              (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) }
+                       {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3)
+                                                                (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn)
+                                                                (Just (Header (getSTRINGs $2) (getSTRING $2)))
+                                                                (getSTRING $3)))}
 
            | '{-# CTYPE'        STRING '#-}'
-                       {% fmap Just $ amsr (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) Nothing (getSTRING $2)))
-                              (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) }
+                       {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2)
+                                                                (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn)
+                                                                Nothing (getSTRING $2)))}
 
            |           { Nothing }
 
@@ -2073,11 +2075,13 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.
 
 maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) }
         : '{-# DEPRECATED' strings '#-}'
-                            {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))
-                                (AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) }
+                            {% fmap Just $ amsA' (sLL $1 $> $
+                                DeprecatedTxt (getDEPRECATED_PRAGs $1, AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn)
+                                              (map stringLiteralToHsDocWst $ snd $ unLoc $2))}
         | '{-# WARNING' warning_category strings '#-}'
-                            {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (getWARNING_PRAGs $1) $2 (map stringLiteralToHsDocWst $ snd $ unLoc $3))
-                                (AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)}
+                            {% fmap Just $ amsA' (sLL $1 $> $
+                                WarningTxt (getWARNING_PRAGs $1, AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)
+                                           $2 (map stringLiteralToHsDocWst $ snd $ unLoc $3))}
         |  {- empty -}      { Nothing }
 
 warning_category :: { Maybe (LocatedE (InWarningCategory GhcPs)) }
@@ -2106,7 +2110,7 @@ warning :: { OrdList (LWarnDecl GhcPs) }
         : warning_category namespace_spec namelist strings
                 {% fmap unitOL $ amsA' (L (comb4 $1 $2 $3 $4)
                      (Warning (fst $ unLoc $4) (unLoc $2) (unLoc $3)
-                              (WarningTxt NoSourceText $1 (map stringLiteralToHsDocWst $ snd $ unLoc $4)))) }
+                              (WarningTxt (NoSourceText, noAnn) $1 (map stringLiteralToHsDocWst $ snd $ unLoc $4)))) }
 
 namespace_spec :: { Located (NamespaceSpecifier GhcPs) }
   : 'type'      { sL1 $1 $ TypeNamespaceSpecifier (epTok $1) }
@@ -2134,7 +2138,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) }
 deprecation :: { OrdList (LWarnDecl GhcPs) }
         : namespace_spec namelist strings
              {% fmap unitOL $ amsA' (sL (comb3 $1 $2 $>) $ (Warning (fst $ unLoc $3) (unLoc $1) (unLoc $2)
-                                          (DeprecatedTxt NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }
+                                          (DeprecatedTxt (NoSourceText, noAnn) $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }
 
 strings :: { Located ((EpToken "[", EpToken "]"),[Located StringLiteral]) }
     : STRING             { sL1 $1 (noAnn,[L (gl $1) (getStringLiteral $1)]) }


=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -27,9 +27,9 @@ module GHC.Parser.Annotation (
   EpAnnCO,
 
   -- ** Annotations in 'GenLocated'
-  LocatedA, LocatedN, LocatedAn, LocatedP,
+  LocatedA, LocatedN, LocatedAn,
   LocatedE, LocatedBF,
-  SrcSpanAnnA, SrcSpanAnnP, SrcSpanAnnN,
+  SrcSpanAnnA, SrcSpanAnnN,
   SrcSpanAnnBF,
 
   -- ** Annotation data types used in 'GenLocated'
@@ -428,7 +428,6 @@ emptyComments = EpaComments []
 type LocatedA = GenLocated SrcSpanAnnA
 type LocatedN = GenLocated SrcSpanAnnN
 
-type LocatedP = GenLocated SrcSpanAnnP
 type LocatedBF = GenLocated SrcSpanAnnBF
 
 -- | Annotation for items appearing in a list. They can have one or
@@ -439,7 +438,6 @@ type SrcSpanAnnA = EpAnn [TrailingAnn]
 -- on the context, such as backticks.
 type SrcSpanAnnN = EpAnn NameAnn
 
-type SrcSpanAnnP = EpAnn AnnPragma
 type SrcSpanAnnBF = EpAnn AnnBooleanFormula
 
 type LocatedE = GenLocated EpaLocation


=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -229,7 +229,7 @@ mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn
 mkTyData :: SrcSpan
          -> Bool
          -> NewOrData
-         -> Maybe (LocatedP (CType GhcPs))
+         -> Maybe (LocatedA (CType GhcPs))
          -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)
          -> Maybe (LHsKind GhcPs)
          -> [LConDecl GhcPs]
@@ -251,7 +251,7 @@ mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))
                                    tcdDataDefn = defn,
                                    tcdModifiers = [] })) }
 
-mkDataDefn :: Maybe (LocatedP (CType GhcPs))
+mkDataDefn :: Maybe (LocatedA (CType GhcPs))
            -> Maybe (LHsContext GhcPs)
            -> Maybe (LHsKind GhcPs)
            -> DataDefnCons (LConDecl GhcPs)
@@ -326,7 +326,7 @@ mkTyFamInstEqn loc bndrs lhs rhs annEq
 
 mkDataFamInst :: SrcSpan
               -> NewOrData
-              -> Maybe (LocatedP (CType GhcPs))
+              -> Maybe (LocatedA (CType GhcPs))
               -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs
                         , LHsType GhcPs)
               -> Maybe (LHsKind GhcPs)


=====================================
compiler/GHC/Tc/Deriv.hs
=====================================
@@ -11,7 +11,7 @@
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
 -- | Handles @deriving@ clauses on @data@ declarations.
-module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where
+module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..), tcOverlapMode ) where
 
 import GHC.Prelude
 
@@ -776,12 +776,12 @@ deriveStandalone (L loc (DerivDecl (warn, _) deriv_ty mb_lderiv_strat overlap_mo
 
 tcOverlapMode :: OverlapMode GhcRn -> OverlapMode GhcTc
 tcOverlapMode = \case
-  NoOverlap    s -> NoOverlap    s
-  Overlappable s -> Overlappable s
-  Overlapping  s -> Overlapping  s
-  Overlaps     s -> Overlaps     s
-  Incoherent   s -> Incoherent   s
-  NonCanonical s -> NonCanonical s
+  NoOverlap    s -> NoOverlap    (fst s)
+  Overlappable s -> Overlappable (fst s)
+  Overlapping  s -> Overlapping  (fst s)
+  Overlaps     s -> Overlaps     (fst s)
+  Incoherent   s -> Incoherent   (fst s)
+  NonCanonical s -> NonCanonical (fst s)
 
 -- Typecheck the type in a standalone deriving declaration.
 --


=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -559,7 +559,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_ext = lwarn
                 -- Dfun location is that of instance *header*
 
         ; let warn = fmap unLoc lwarn
-        ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name
+        ; ispec <- newClsInst (fmap (tcOverlapMode . unLoc) overlap_mode) dfun_name
                               tyvars theta clas inst_tys warn
 
         ; let inst_binds = InstBindings


=====================================
compiler/GHC/Tc/Utils/Instantiate.hs
=====================================
@@ -905,7 +905,7 @@ hasFixedRuntimeRepRes std_nm user_expr ty = mapM_ do_check mb_arity
 ************************************************************************
 -}
 
-getOverlapFlag :: Maybe (OverlapMode (GhcPass p)) -- User pragma if any
+getOverlapFlag :: Maybe (OverlapMode GhcTc) -- User pragma if any
                -> TcM OverlapFlag
 -- Construct the OverlapFlag from the global module flags,
 -- but if the overlap_mode argument is (Just m),
@@ -929,9 +929,9 @@ getOverlapFlag overlap_mode_prag
 
               overlap_mode
                 | Just m <- overlap_mode_prag = m
-                | incoherent_ok               = Incoherent NoSourceText
-                | overlap_ok                  = Overlaps   NoSourceText
-                | otherwise                   = NoOverlap  NoSourceText
+                | incoherent_ok               = Incoherent noAnn
+                | overlap_ok                  = Overlaps   noAnn
+                | otherwise                   = NoOverlap  noAnn
 
               -- final_overlap_mode: the `-fspecialise-incoherents` flag controls the
               -- meaning of the `Incoherent` overlap mode: as either an Incoherent overlap
@@ -957,7 +957,7 @@ tcGetInsts :: TcM [ClsInst]
 -- Gets the local class instances.
 tcGetInsts = fmap tcg_insts getGblEnv
 
-newClsInst :: Maybe (OverlapMode (GhcPass p))   -- User pragma
+newClsInst :: Maybe (OverlapMode GhcTc)   -- User pragma
            -> Name -> [TyVar] -> ThetaType
            -> Class -> [Type] -> Maybe (WarningTxt GhcRn) -> TcM ClsInst
 newClsInst overlap_mode dfun_name tvs theta clas tys warn


=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -337,7 +337,6 @@ cvtDec (ClassD ctxt cl tvs fds decs)
         }
 
 cvtDec (InstanceD o ctxt ty decs)
-  -- = do  { (binds', sigs', fams', ats', adts') <- cvt_ci_decs InstanceDecl decs
   = do  { decs' <- cvt_ci_decs InstanceDecl decs
         ; let (fams', decls') = partitionWith is_fam_decl decs'
         ; for_ (nonEmpty fams') $ \ bad_fams ->
@@ -356,10 +355,10 @@ cvtDec (InstanceD o ctxt ty decs)
   where
   overlap pragma =
     case pragma of
-      TH.Overlaps      -> Hs.Overlaps     (SourceText $ fsLit "{-# OVERLAPS")
-      TH.Overlappable  -> Hs.Overlappable (SourceText $ fsLit "{-# OVERLAPPABLE")
-      TH.Overlapping   -> Hs.Overlapping  (SourceText $ fsLit "{-# OVERLAPPING")
-      TH.Incoherent    -> Hs.Incoherent   (SourceText $ fsLit "{-# INCOHERENT")
+      TH.Overlaps      -> Hs.Overlaps     (SourceText $ fsLit "{-# OVERLAPS", noAnn)
+      TH.Overlappable  -> Hs.Overlappable (SourceText $ fsLit "{-# OVERLAPPABLE", noAnn)
+      TH.Overlapping   -> Hs.Overlapping  (SourceText $ fsLit "{-# OVERLAPPING", noAnn)
+      TH.Incoherent    -> Hs.Incoherent   (SourceText $ fsLit "{-# INCOHERENT", noAnn)
 
 
 


=====================================
compiler/GHC/Types/ForeignCall.hs
=====================================
@@ -109,6 +109,7 @@ import Data.Data (Data)
 import Data.Functor ((<&>))
 
 import Control.DeepSeq (NFData(..))
+import GHC.Parser.Annotation (AnnPragma, noAnn)
 
 {-
 ************************************************************************
@@ -213,11 +214,11 @@ instance Outputable CCallSpec where
 
 defaultCType :: String -> CType (GhcPass p)
 defaultCType =
-  CType (CTypeGhc NoSourceText NoSourceText) Nothing . fsLit
+  CType (CTypeGhc NoSourceText NoSourceText noAnn) Nothing . fsLit
 
-mkCType :: SourceText -> SourceText -> Maybe (Header (GhcPass p)) -> FastString -> CType (GhcPass p)
-mkCType x y m =
-  CType (CTypeGhc x y) m
+mkCType :: SourceText -> SourceText -> AnnPragma -> Maybe (Header (GhcPass p)) -> FastString -> CType (GhcPass p)
+mkCType x y ann m =
+  CType (CTypeGhc x y ann) m
 
 typeCheckCType :: CType GhcRn -> CType GhcTc
 typeCheckCType (CType x y z) = CType x (typeCheckHeader <$> y) z
@@ -302,6 +303,7 @@ data StaticTargetGhc = StaticTargetGhc
 data CTypeGhc = CTypeGhc
   { cTypeSourceText :: SourceText
   , cTypeOtherText  :: SourceText
+  , cTypeAnn        :: AnnPragma
   }
   deriving (Data, Eq)
 
@@ -350,12 +352,15 @@ instance Binary CTypeGhc where
     put_ bh ct = do
       put_ bh (cTypeSourceText ct)
       put_ bh (cTypeOtherText  ct)
+      put_ bh (cTypeAnn        ct)
     get bh = do
       str1 <- get bh
       str2  <- get bh
+      ann  <- get bh
       return $ CTypeGhc
         { cTypeSourceText = str1
         , cTypeOtherText  = str2
+        , cTypeAnn        = ann
         }
 
 instance NFData StaticTargetGhc where


=====================================
compiler/GHC/Unit/Module/Warnings.hs
=====================================
@@ -156,8 +156,8 @@ warningTxtSame w1 w2
 instance Outputable (InWarningCategory (GhcPass pass)) where
   ppr (InWarningCategory _ wt) = text "in" <+> doubleQuotes (ppr wt)
 
-type instance XDeprecatedTxt       (GhcPass _) = SourceText
-type instance XWarningTxt          (GhcPass _) = SourceText
+type instance XDeprecatedTxt       (GhcPass _) = (SourceText, AnnPragma)
+type instance XWarningTxt          (GhcPass _) = (SourceText, AnnPragma)
 type instance XXWarningTxt         (GhcPass _) = DataConCantHappen
 type instance XInWarningCategory   (GhcPass _) = (EpToken "in", SourceText)
 type instance XXInWarningCategory  (GhcPass _) = DataConCantHappen
@@ -165,7 +165,7 @@ type instance XXInWarningCategory  (GhcPass _) = DataConCantHappen
 type instance Anno (WithHsDocIdentifiers StringLiteral pass) = EpaLocation
 type instance Anno (InWarningCategory (GhcPass pass)) = EpaLocation
 type instance Anno (WarningCategory) = EpaLocation
-type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP
+type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnA
 
 deriving stock instance Eq (WarningTxt GhcPs)
 deriving stock instance Eq (WarningTxt GhcRn)
@@ -190,15 +190,15 @@ deriving instance Uniquable WarningCategory
 instance Outputable (WarningTxt (GhcPass pass)) where
     ppr (WarningTxt lsrc mcat ws)
       = case lsrc of
-            NoSourceText   -> pp_ws ws
-            SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}"
+            (NoSourceText, _)   -> pp_ws ws
+            (SourceText src, _) -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}"
         where
           ctg_doc = maybe empty (\ctg -> ppr ctg) mcat
 
     ppr (DeprecatedTxt lsrc ds)
       = case lsrc of
-          NoSourceText   -> pp_ws ds
-          SourceText src -> ftext src <+> pp_ws ds <+> text "#-}"
+          (NoSourceText, _)   -> pp_ws ds
+          (SourceText src, _) -> ftext src <+> pp_ws ds <+> text "#-}"
 
 pp_ws :: [LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc
 pp_ws [l] = ppr $ unLoc l


=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -1558,26 +1558,26 @@ instance ExactPrint ModuleName where
 
 -- ---------------------------------------------------------------------
 
-instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
-  getAnnotationEntry = entryFromLocatedA
-  setAnnotationAnchor = setAnchorAn
+instance ExactPrint (WarningTxt GhcPs) where
+  getAnnotationEntry _ = NoEntryVal
+  setAnnotationAnchor a _ _ _ = a
 
-  exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt src mb_cat ws)) = do
+  exact (WarningTxt (src, AnnPragma o c (os,cs) l1 l2 t m) mb_cat ws) = do
     o' <- markAnnOpen'' o src "{-# WARNING"
     mb_cat' <- markAnnotated mb_cat
     os' <- markEpToken os
     ws' <- mapM markAnnotated ws
     cs' <- markEpToken cs
     c' <- markEpToken c
-    return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt src mb_cat' ws'))
+    return (WarningTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) mb_cat' ws')
 
-  exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do
+  exact (DeprecatedTxt (src, AnnPragma o c (os,cs) l1 l2 t m) ws) = do
     o' <- markAnnOpen'' o src "{-# DEPRECATED"
     os' <- markEpToken os
     ws' <- mapM markAnnotated ws
     cs' <- markEpToken cs
     c' <- markEpToken c
-    return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws'))
+    return (DeprecatedTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) ws')
 
 instance Typeable p => ExactPrint (InWarningCategory (GhcPass p)) where
   getAnnotationEntry _ = NoEntryVal
@@ -2248,40 +2248,40 @@ instance ExactPrint (TyFamInstDecl GhcPs) where
 
 -- ---------------------------------------------------------------------
 
-instance Typeable p => ExactPrint (LocatedP (OverlapMode (GhcPass p))) where
-  getAnnotationEntry = entryFromLocatedA
-  setAnnotationAnchor = setAnchorAn
+instance ExactPrint (OverlapMode GhcPs) where
+  getAnnotationEntry _ = NoEntryVal
+  setAnnotationAnchor a _ _ _ = a
 
   -- NOTE: NoOverlap is only used in the typechecker
-  exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (NoOverlap src)) = do
+  exact (NoOverlap (src, AnnPragma o c s l1 l2 t m)) = do
     o' <- markAnnOpen'' o src "{-# NO_OVERLAP"
     c' <- markEpToken c
-    return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (NoOverlap src))
+    return (NoOverlap (src, AnnPragma o' c' s l1 l2 t m))
 
-  exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlappable src)) = do
+  exact (Overlappable (src, AnnPragma o c s l1 l2 t m)) = do
     o' <- markAnnOpen'' o src "{-# OVERLAPPABLE"
     c' <- markEpToken c
-    return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlappable src))
+    return (Overlappable (src, AnnPragma o' c' s l1 l2 t m))
 
-  exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlapping src)) = do
+  exact (Overlapping (src, AnnPragma o c s l1 l2 t m)) = do
     o' <- markAnnOpen'' o src "{-# OVERLAPPING"
     c' <- markEpToken c
-    return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlapping src))
+    return (Overlapping (src, AnnPragma o' c' s l1 l2 t m))
 
-  exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Overlaps src)) = do
+  exact (Overlaps (src, AnnPragma o c s l1 l2 t m)) = do
     o' <- markAnnOpen'' o src "{-# OVERLAPS"
     c' <- markEpToken c
-    return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Overlaps src))
+    return (Overlaps (src, AnnPragma o' c' s l1 l2 t m))
 
-  exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (Incoherent src)) = do
+  exact (Incoherent (src, AnnPragma o c s l1 l2 t m)) = do
     o' <- markAnnOpen'' o src "{-# INCOHERENT"
     c' <- markEpToken c
-    return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Incoherent src))
+    return (Incoherent (src, AnnPragma o' c' s l1 l2 t m))
 
-  exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (NonCanonical src)) = do
+  exact (NonCanonical (src, AnnPragma o c s l1 l2 t m)) = do
     o' <- markAnnOpen'' o src "{-# INCOHERENT"
     c' <- markEpToken c
-    return (L (EpAnn l (AnnPragma o' c' s l1 l2 t m) cs) (Incoherent src))
+    return (Incoherent (src, AnnPragma o' c' s l1 l2 t m))
 
 -- ---------------------------------------------------------------------
 
@@ -4407,13 +4407,14 @@ instance ExactPrint t => ExactPrint (HsModifierOf t GhcPs) where
 
 -- ---------------------------------------------------------------------
 
-instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where
-  getAnnotationEntry = entryFromLocatedA
-  setAnnotationAnchor = setAnchorAn
+instance Typeable p => ExactPrint (CType (GhcPass p)) where
+  getAnnotationEntry _ = NoEntryVal
+  setAnnotationAnchor a _ _ _ = a
 
-  exact (L (EpAnn l (AnnPragma o c s l1 l2 t m) cs) (CType ext mh ct)) = do
+  exact (CType ext mh ct) = do
     let stp  = cTypeSourceText ext
         stct = cTypeOtherText  ext
+        AnnPragma o c s l1 l2 t m = cTypeAnn ext
     o' <- markAnnOpen'' o stp "{-# CTYPE"
     l1' <- case mh of
              Nothing -> return l1
@@ -4421,7 +4422,7 @@ instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where
                printStringAtAA l1 (toSourceTextWithSuffix srcH "" "")
     l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackFS ct) "")
     c' <- markEpToken c
-    return (L (EpAnn l (AnnPragma o' c' s l1' l2' t m) cs) (CType ext mh ct))
+    return (CType (ext { cTypeAnn = AnnPragma o' c' s l1' l2' t m }) mh ct)
 
 -- ---------------------------------------------------------------------
 


=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -834,8 +834,8 @@ type instance Anno (FamilyResultSig DocNameI) = EpAnn NoEpAnns
 type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA
 type instance Anno (HsSigType DocNameI) = SrcSpanAnnA
 type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnBF
-type instance Anno (OverlapMode DocNameI) = EpAnn AnnPragma
-type instance Anno (CType DocNameI) = EpAnn AnnPragma
+type instance Anno (OverlapMode DocNameI) = SrcSpanAnnA
+type instance Anno (CType DocNameI) = SrcSpanAnnA
 type instance Anno (Header DocNameI) = EpAnn AnnPragma
 type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA
 type instance Anno (HsContextDetails DocNameI a) = SrcSpanAnnA



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b5adaa3501d9a247d2f34a6796e354...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b5adaa3501d9a247d2f34a6796e354...
You're receiving this email because of your account on gitlab.haskell.org.

    

Alan Zimmerman (＠alanz)

tags

participants (1)