[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Fix note typo

2 Aug 2026


      Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


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

- - - - -
6efd74d5 by Andreas Klebinger at 2026-08-02T16:16:24-04:00
Apply oneShot Monad trick to STG LintM

- - - - -
474e654c by Andreas Klebinger at 2026-08-02T16:16:24-04:00
stgLint: Use a single reader env for read only arguments.

- - - - -
66c5544e by Alan Zimmerman at 2026-08-02T16:16:25-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.

- - - - -


8 changed files:

- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Types/ForeignCall.hs
- libraries/ghc-internal/src/GHC/Internal/Ix.hs
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs


Changes:

=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1583,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


=====================================
compiler/GHC/Parser.y
=====================================
@@ -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/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.
 


=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -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
=====================================
@@ -837,7 +837,7 @@ type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA
 type instance Anno (HsSigType DocNameI) = SrcSpanAnnA
 type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnBF
 type instance Anno (OverlapMode DocNameI) = SrcSpanAnnA
-type instance Anno (CType DocNameI) = EpAnn AnnPragma
+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/93a68c14430f035b61bade285a60d12...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/93a68c14430f035b61bade285a60d12...
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

    

Marge Bot (＠marge-bot)

tags

participants (1)