[Git][ghc/ghc][wip/int-index/t18725] 6 commits: EPA: Remove LocatedP from OverlapMode

4 Aug 2026


      Vladislav Zavialov pushed to branch wip/int-index/t18725 at Glasgow Haskell Compiler / GHC


Commits:
85b10c00 by Alan Zimmerman at 2026-07-31T22:09:47+01:00
EPA: Remove LocatedP from OverlapMode

We have

  type LocatedP = GenLocated SrcSpanAnnP
  type SrcSpanAnnP = EpAnn AnnPragma

As the first step in removing this in favour of LocatedA which only
captures location, comments and trailing annotations, we remove it
from OverlapMode

We do this by moving the AnnPragma into the TTG extension point
instead.

- - - - -
c9a34a00 by Viktor Dukhovni at 2026-08-02T04:34:17-04:00
Fix note typo

- - - - -
4f2a21f7 by Andreas Klebinger at 2026-08-02T22:46:46-04:00
Apply oneShot Monad trick to STG LintM

- - - - -
21e4b89d by Andreas Klebinger at 2026-08-02T22:46:46-04:00
stgLint: Use a single reader env for read only arguments.

- - - - -
d415f38a by Alan Zimmerman at 2026-08-02T22:47:27-04:00
EPA: Remove LocatedP from CType

The next step of removing use of LocatedP by moving
the AnnPragma for CType into its TTG extension point
instead.

- - - - -
f938dae0 by Vladislav Zavialov at 2026-08-04T15:22:30+00:00
Test cases for #18725

Starting with GHC 9.4 (the first release to include 268efcc9a4), the program in
this ticket no longer panics. A standalone kind signature breaks the recursive
loop, so the type constructor can be used in a kind within its own group.

T18725a checks that this is accepted with the signature present, while T18725b
confirms it is still rejected without it.

- - - - -


19 changed files:

- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Decls/Overlap.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Stg/Lint.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
- libraries/ghc-internal/src/GHC/Internal/Ix.hs
- + testsuite/tests/saks/should_compile/T18725a.hs
- testsuite/tests/saks/should_compile/all.T
- + testsuite/tests/saks/should_fail/T18725b.hs
- + testsuite/tests/saks/should_fail/T18725b.stderr
- testsuite/tests/saks/should_fail/all.T
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs


Changes:

=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1158,20 +1158,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
@@ -1578,7 +1583,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
@@ -1593,7 +1598,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
=====================================
@@ -26,6 +26,8 @@ import GHC.Prelude
 
 import GHC.Hs.Extension
 
+import GHC.Parser.Annotation ( AnnPragma )
+
 import Language.Haskell.Syntax.Decls.Overlap
 import Language.Haskell.Syntax.Extension
 
@@ -65,7 +67,9 @@ 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
 


=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1752,7 +1752,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/Parser.y
=====================================
@@ -1471,15 +1471,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 }
@@ -1707,15 +1707,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 }
 


=====================================
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/Stg/Lint.hs
=====================================
@@ -92,6 +92,7 @@ be ill-typed in Core.  But it must still be well-kinded!
 -}
 
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 module GHC.Stg.Lint ( lintStgTopBindings ) where
 
@@ -123,6 +124,7 @@ import GHC.Unit.Module            ( Module )
 import GHC.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
 
 import Control.Monad
+import GHC.Exts            ( oneShot )
 import GHC.Core.Multiplicity (scaledThing)
 import GHC.Settings (Platform)
 import GHC.Core.TyCon (primRepCompatible, primRepsCompatible)
@@ -432,17 +434,40 @@ The Lint monad
 ************************************************************************
 -}
 
-newtype LintM a = LintM
-    { unLintM :: Module
-              -> LintFlags
-              -> DiagOpts          -- Diagnostic options
-              -> StgPprOpts        -- Pretty-printing options
+data LintReaderEnv = LintReaderEnv
+  { le_mod ::  !Module
+  , le_flags :: !LintFlags
+  , le_diag_opts :: !DiagOpts  -- Diagnostic options
+  , le_ppr_opts :: !StgPprOpts  -- Pretty-printing options
+  }
+
+newtype LintM a = LintM'
+    { unLintM :: LintReaderEnv
               -> [LintLocInfo]     -- Locations
               -> IdSet             -- Local vars in scope
               -> Bag SDoc        -- Error messages so far
               -> (a, Bag SDoc)   -- Result and error messages (if any)
     }
-    deriving (Functor)
+instance Functor LintM where
+  fmap f (LintM m) =
+    LintM $ \env loc scope errs ->
+      case m env loc scope errs of
+        (a, errs') -> (f a, errs')
+
+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad
+{-# COMPLETE LintM #-}
+pattern LintM :: (LintReaderEnv
+              -> [LintLocInfo]
+              -> IdSet
+              -> Bag SDoc
+              -> (a, Bag SDoc))
+              -> LintM a
+pattern LintM m <- LintM' m
+  where
+    LintM m = LintM' $ oneShot (\env -> oneShot
+                                      (\loc -> oneShot
+                                        (\scope -> oneShot
+                                          (\errs -> m env loc scope errs))))
 
 data LintFlags = LintFlags { lf_unarised :: !Bool
                            , lf_platform :: !Platform
@@ -473,14 +498,16 @@ pp_binders bs
 
 initL :: Platform -> DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
 initL platform diag_opts this_mod unarised opts locals (LintM m) = do
-  let (_, errs) = m this_mod (LintFlags unarised platform) diag_opts opts [] locals emptyBag
+  let !flags = LintFlags unarised platform
+      !env = LintReaderEnv this_mod flags diag_opts opts
+      (_, errs) = m env [] locals emptyBag
   if isEmptyBag errs then
       Nothing
   else
       Just (vcat (punctuate blankLine (bagToList errs)))
 
 instance Applicative LintM where
-      pure a = LintM $ \_mod _lf _df _opts _loc _scope errs -> (a, errs)
+      pure a = LintM $ \_env _loc _scope errs -> (a, errs)
       (<*>) = ap
       (*>)  = thenL_
 
@@ -489,14 +516,14 @@ instance Monad LintM where
     (>>)  = (*>)
 
 thenL :: LintM a -> (a -> LintM b) -> LintM b
-thenL m k = LintM $ \mod lf diag_opts opts loc scope errs
-  -> case unLintM m mod lf diag_opts opts loc scope errs of
-      (r, errs') -> unLintM (k r) mod lf diag_opts opts loc scope errs'
+thenL m k = LintM $ \env loc scope errs
+  -> case unLintM m env loc scope errs of
+      (r, errs') -> unLintM (k r) env loc scope errs'
 
 thenL_ :: LintM a -> LintM b -> LintM b
-thenL_ m k = LintM $ \mod lf diag_opts opts loc scope errs
-  -> case unLintM m mod lf diag_opts opts loc scope errs of
-      (_, errs') -> unLintM k mod lf diag_opts opts loc scope errs'
+thenL_ m k = LintM $ \env loc scope errs
+  -> case unLintM m env loc scope errs of
+      (_, errs') -> unLintM k env loc scope errs'
 
 checkL :: Bool -> SDoc -> LintM ()
 checkL True  _   = return ()
@@ -525,7 +552,8 @@ checkPostUnariseId id
     id_ty = idType id
 
 addErrL :: SDoc -> LintM ()
-addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc)
+addErrL msg = LintM $ \LintReaderEnv{le_diag_opts = df} loc _scope errs
+  -> ((), addErr df errs msg loc)
 
 addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
 addErr diag_opts errs_so_far msg locs
@@ -537,23 +565,23 @@ addErr diag_opts errs_so_far msg locs
     mk_msg []      = msg
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
-addLoc extra_loc m = LintM $ \mod lf diag_opts opts loc scope errs
-   -> unLintM m mod lf diag_opts opts (extra_loc:loc) scope errs
+addLoc extra_loc m = LintM $ \env loc scope errs
+   -> unLintM m env (extra_loc:loc) scope errs
 
 addInScopeVars :: [Id] -> LintM a -> LintM a
-addInScopeVars ids m = LintM $ \mod lf diag_opts opts loc scope errs
+addInScopeVars ids m = LintM $ \env loc scope errs
  -> let
         new_set = mkVarSet ids
-    in unLintM m mod lf diag_opts opts loc (scope `unionVarSet` new_set) errs
+    in unLintM m env loc (scope `unionVarSet` new_set) errs
 
 getLintFlags :: LintM LintFlags
-getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs)
+getLintFlags = LintM $ \LintReaderEnv{le_flags = lf} _loc _scope errs -> (lf, errs)
 
 getStgPprOpts :: LintM StgPprOpts
-getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs)
+getStgPprOpts = LintM $ \LintReaderEnv{le_ppr_opts = opts} _loc _scope errs -> (opts, errs)
 
 checkInScope :: Id -> LintM ()
-checkInScope id = LintM $ \mod _lf diag_opts _opts loc scope errs
+checkInScope id = LintM $ \LintReaderEnv{le_mod = mod, le_diag_opts = diag_opts} loc scope errs
  -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then
         ((), addErr diag_opts errs (hsep [ppr id, dcolon, ppr (idType id),
                                     text "is out of scope"]) loc)


=====================================
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
=====================================
@@ -558,7 +558,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty
                 -- 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
=====================================
@@ -72,7 +72,6 @@ import GHC.Rename.Utils( mkRnSyntaxExpr )
 import GHC.Types.Id.Make( mkDictFunId )
 import GHC.Types.Arity ( Arity, VisArity )
 import GHC.Types.Basic ( TypeOrKind(..) )
-import GHC.Types.SourceText
 import GHC.Types.SrcLoc as SrcLoc
 import GHC.Types.Var.Env
 import GHC.Types.Id
@@ -912,7 +911,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),
@@ -936,9 +935,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
@@ -964,7 +963,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
=====================================
@@ -356,10 +356,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 . packHText
+  CType (CTypeGhc NoSourceText NoSourceText noAnn) Nothing . packHText
 
-mkCType :: SourceText -> SourceText -> Maybe (Header (GhcPass p)) -> HText -> CType (GhcPass p)
-mkCType x y m =
-  CType (CTypeGhc x y) m
+mkCType :: SourceText -> SourceText -> AnnPragma -> Maybe (Header (GhcPass p)) -> HText -> 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)
 
@@ -349,6 +351,7 @@ instance Binary CTypeGhc where
       return $ CTypeGhc
         { cTypeSourceText = str1
         , cTypeOtherText  = str2
+        , cTypeAnn        = noAnn
         }
 
 instance NFData StaticTargetGhc where


=====================================
libraries/ghc-internal/src/GHC/Internal/Ix.hs
=====================================
@@ -142,7 +142,7 @@ For 1-d, 2-d, and 3-d arrays of Int we have specialised instances to avoid this.
 
 Note [Out-of-bounds error messages]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The default method for 'index' generates hoplelessIndexError, because
+The default method for 'index' generates 'hopelessIndexError', because
 Ix doesn't have Show as a superclass.  For particular base types we
 can do better, so we override the default method for index.
 


=====================================
testsuite/tests/saks/should_compile/T18725a.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE ExplicitForAll, KindSignatures, StandaloneKindSignatures,
+             DataKinds, GADTs #-}
+
+module T18725a where
+
+import Data.Kind (Type)
+
+type U :: Type
+data U where P :: forall u. E u -> U
+data E (u :: U)


=====================================
testsuite/tests/saks/should_compile/all.T
=====================================
@@ -35,6 +35,7 @@ test('T16726', normal, compile, [''])
 test('T16731', normal, compile, [''])
 test('T16721', normal, ghci_script, ['T16721.script'])
 test('T16756a', normal, compile, [''])
+test('T18725a', normal, compile, [''])
 
 test('saks027', req_th, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('saks028', req_th, compile, [''])


=====================================
testsuite/tests/saks/should_fail/T18725b.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE ExplicitForAll, KindSignatures, StandaloneKindSignatures,
+             DataKinds, GADTs #-}
+
+module T18725b where
+
+-- type U :: Type      -- Rejected without the sig
+data U where P :: forall u. E u -> U
+data E (u :: U)


=====================================
testsuite/tests/saks/should_fail/T18725b.stderr
=====================================
@@ -0,0 +1,6 @@
+T18725b.hs:8:14: error: [GHC-85413]
+    • Type constructor ‘U’ cannot be used here
+        (it is defined and used in the same recursive group)
+    • In the kind ‘U’
+      In the data type declaration for ‘E’
+


=====================================
testsuite/tests/saks/should_fail/all.T
=====================================
@@ -38,3 +38,5 @@ test('T18863d', normal, compile_fail, [''])
 test('T20916', normal, compile_fail, [''])
 test('saks018-fail', normal, compile_fail, [''])
 test('saks021-fail', normal, compile_fail, [''])
+test('T18725b', normal, compile_fail, [''])
+


=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -2246,40 +2246,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))
 
 -- ---------------------------------------------------------------------
 
@@ -4401,13 +4401,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
@@ -4415,7 +4416,7 @@ instance Typeable p => ExactPrint (LocatedP (CType (GhcPass p))) where
                printStringAtAA l1 (toSourceTextWithSuffix srcH "" "")
     l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackHText 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
=====================================
@@ -836,8 +836,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/066783c056890adbe39a59d63c2ecd1...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/066783c056890adbe39a59d63c2ecd1...
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

    

[Git][ghc/ghc][wip/int-index/t18725] 6 commits: EPA: Remove LocatedP from OverlapMode

Vladislav Zavialov (＠int-index)