[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: ci: Actually pass --ignore-perf-failures to the testsuite driver

12 Sep 2026


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


Commits:
4e9297ea by Simon Jakobi at 2026-09-11T08:32:45-04:00
ci: Actually pass --ignore-perf-failures to the testsuite driver

684c0018d9 changed the IGNORE_PERF_FAILURES handling to append to
RUNTEST_ARGS with bash array syntax, but the three use sites still
expand RUNTEST_ARGS as a scalar, which yields only the first array
element. The appended flag was therefore dropped in every job, so
perf improvements kept failing Marge Bot batches and master pipelines,
contrary to #19562.

Append as a string instead, matching the existing --force-colors
append in test_hadrian.

Fixes #27563.

Assisted-by: Claude Fable 5.1

- - - - -
4f78dfdf by Simon Jakobi at 2026-09-11T08:33:24-04:00
testsuite: Give T26537 a 1.5x compile timeout

Its -fregs-graph compile step tends to time out in unoptimized builds
(#27188, #27776).

Assisted-by: Claude Fable 5.1

- - - - -
130286e3 by Alan Zimmerman at 2026-09-11T08:34:08-04:00
EPA: Remove ListBanana / ListParens from AnnListBrackets

This is a step towards making AnnList only represent
lists of items which can have either braces or layout.

- - - - -
cc447dac by Simon Jakobi at 2026-09-11T14:43:13-04:00
Reject ~, UNPACK and multiplicity annotations on type data fields

Only `!` was rejected so far. `~`, UNPACK and multiplicity annotations
were silently accepted. None of them make sense at the type level, so
restriction (R3) of Note [Type data declarations] now covers all of
them.

Fixes #27732.

Assisted-by: Claude Fable 5.1

- - - - -
da7bb249 by Alan Zimmerman at 2026-09-11T14:43:14-04:00
EPA: Add a Note for the exact print main loop

- - - - -


29 changed files:

- .gitlab/ci.sh
- + changelog.d/27732
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Errors/Types.hs
- docs/users_guide/exts/type_data.rst
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/ghc-api/T25121_status.stdout
- + testsuite/tests/type-data/should_fail/T27732a.hs
- + testsuite/tests/type-data/should_fail/T27732a.stderr
- + testsuite/tests/type-data/should_fail/T27732b.hs
- + testsuite/tests/type-data/should_fail/T27732b.stderr
- + testsuite/tests/type-data/should_fail/T27732c.hs
- + testsuite/tests/type-data/should_fail/T27732c.stderr
- + testsuite/tests/type-data/should_fail/T27732d.hs
- + testsuite/tests/type-data/should_fail/T27732d.stderr
- + testsuite/tests/type-data/should_fail/T27732e.hs
- + testsuite/tests/type-data/should_fail/T27732e.stderr
- + testsuite/tests/type-data/should_fail/T27732f.hs
- + testsuite/tests/type-data/should_fail/T27732f.stderr
- testsuite/tests/type-data/should_fail/TDStrictnessGADT.stderr
- testsuite/tests/type-data/should_fail/TDStrictnessH98.stderr
- testsuite/tests/type-data/should_fail/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Utils.hs


Changes:

=====================================
.gitlab/ci.sh
=====================================
@@ -1106,7 +1106,7 @@ if [ "${CI_COMMIT_BRANCH:-}" == "master" ] &&  [ "${CI_PROJECT_PATH:-}" == "ghc/
   fi
 fi
 if [ -n "${IGNORE_PERF_FAILURES:-}" ]; then
-  RUNTEST_ARGS=( "${RUNTEST_ARGS[@]:-}" "--ignore-perf-failures=$IGNORE_PERF_FAILURES" )
+  RUNTEST_ARGS="${RUNTEST_ARGS:-} --ignore-perf-failures=$IGNORE_PERF_FAILURES"
 fi
 
 if [[ -z ${BIGNUM_BACKEND:-} ]]; then BIGNUM_BACKEND=gmp; fi


=====================================
changelog.d/27732
=====================================
@@ -0,0 +1,8 @@
+section: language
+synopsis: Reject ``~``, ``UNPACK`` and multiplicity annotations on ``type data`` fields
+description:
+  ``type data`` declarations (:extension:`TypeData`) now reject any
+  strictness, unpackedness or multiplicity annotation on constructor
+  fields. Previously only ``!`` was rejected.
+mrs: !16563
+issues: #27732


=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -294,7 +294,7 @@ type instance XDo            GhcPs = (AnnList, EpaLocation)
 type instance XDo            GhcRn = NoExtField
 type instance XDo            GhcTc = Type
 
-type instance XExplicitList  GhcPs = AnnList
+type instance XExplicitList  GhcPs = (EpToken "[", EpToken "]")
 type instance XExplicitList  GhcRn = NoExtField
 type instance XExplicitList  GhcTc = Type
 -- GhcPs: ExplicitList includes all source-level
@@ -1440,7 +1440,7 @@ type instance XCmdArrApp  GhcPs = (IsUnicodeSyntax, EpaLocation)
 type instance XCmdArrApp  GhcRn = NoExtField
 type instance XCmdArrApp  GhcTc = Type
 
-type instance XCmdArrForm GhcPs = AnnList
+type instance XCmdArrForm GhcPs = (EpUniToken "(|" "⦇", EpUniToken "|)"  "⦈")
 -- | fixity (filled in by the renamer), for forms that were converted from
 -- OpApp's by the renamer
 type instance XCmdArrForm GhcRn = Maybe Fixity


=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -104,7 +104,7 @@ type instance XBangPat GhcPs = EpToken "!"
 type instance XBangPat GhcRn = NoExtField
 type instance XBangPat GhcTc = NoExtField
 
-type instance XListPat GhcPs = AnnList
+type instance XListPat GhcPs = (EpToken "[", EpToken "]")
   -- After parsing, ListPat can refer to a built-in Haskell list pattern
   -- or an overloaded list pattern.
 type instance XListPat GhcRn = NoExtField


=====================================
compiler/GHC/Parser.y
=====================================
@@ -3282,7 +3282,7 @@ aexp2   :: { ECP }
         -- arrow notation extension
         | '(|' aexp cmdargs '|)'  {% runPV (unECP $2) >>= \ $2 ->
                                       fmap ecpFromCmd $
-                                      amsA' (sLL $1 $> $ HsCmdArrForm (AnnList (glRM $1) (ListBanana (epUniTok $1) (epUniTok $4)) []) $2 Prefix
+                                      amsA' (sLL $1 $> $ HsCmdArrForm (epUniTok $1, epUniTok $4) $2 Prefix
                                                            (reverse $3)) }
 
 projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) }
@@ -3414,9 +3414,9 @@ tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn Bool) (LocatedA b)] }
 -- Never empty.
 list :: { forall b. DisambECP b => SrcSpan -> (EpaLocation, EpaLocation) -> PV (LocatedA b) }
         : texp    { \loc (ao,ac) -> unECP $1 >>= \ $1 ->
-                            mkHsExplicitListPV loc [$1] (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) []) }
+                            mkHsExplicitListPV loc [$1] (EpTok ao, EpTok ac) }
         | lexps   { \loc (ao,ac) -> $1 >>= \ $1 ->
-                            mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) []) }
+                            mkHsExplicitListPV loc (reverse $1) (EpTok ao, EpTok ac) }
         | texp '..'  { \loc (ao,ac) -> unECP $1 >>= \ $1 ->
                                   amsA' (L loc $ ArithSeq  (AnnArithSeq (EpTok ao) Nothing (epTok $2) (EpTok ac)) Nothing (From $1))
                                       >>= ecpFromExp' }


=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -519,10 +519,8 @@ data AnnList
       } deriving (Data,Eq)
 
 data AnnListBrackets
-  = ListParens (EpToken "(")         (EpToken ")")
-  | ListBraces (EpToken "{")         (EpToken "}")
+  = ListBraces (EpToken "{")         (EpToken "}")
   | ListSquare (EpToken "[")         (EpToken "]")
-  | ListBanana (EpUniToken "(|" "⦇") (EpUniToken "|)"  "⦈")
   | ListNone
   deriving (Data,Eq)
 
@@ -1094,10 +1092,8 @@ instance Outputable AnnList where
     = text "AnnList" <+> ppr l <+> ppr p <+> ppr s
 
 instance Outputable AnnListBrackets where
-  ppr (ListParens o c) = text "ListParens" <+> ppr o <+> ppr c
   ppr (ListBraces o c) = text "ListBraces" <+> ppr o <+> ppr c
   ppr (ListSquare o c) = text "ListSquare" <+> ppr o <+> ppr c
-  ppr (ListBanana o c) = text "ListBanana" <+> ppr o <+> ppr c
   ppr ListNone         = text "ListNone"
 
 instance Outputable AnnCType where


=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1827,7 +1827,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
   mkHsTySigPV
     :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> TokDcolon -> PV (LocatedA b)
   -- | Disambiguate "[a,b,c]" (list syntax)
-  mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList -> PV (LocatedA b)
+  mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> (EpToken "[", EpToken "]") -> PV (LocatedA b)
   -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices)
   mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (LocatedA b)
   -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates)


=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -71,7 +71,6 @@ import GHC.Data.Graph.Directed ( SCC, flattenSCC, Node(..)
                                , stronglyConnCompFromEdgedVerticesUniq )
 import GHC.Data.OrdList
 import qualified GHC.LanguageExtensions as LangExt
-import GHC.Core.DataCon ( isSrcStrict )
 
 import Control.Monad
 import Data.Bifunctor ( first )
@@ -2116,8 +2115,8 @@ rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = cond
       = do {
            ; when (has_labelled_fields condecl) $
                failWith $ TcRnTypeDataForbids TypeDataForbidsLabelledFields
-           ; when (has_strictness_flags condecl) $
-               failWith $ TcRnTypeDataForbids TypeDataForbidsStrictnessAnnotations
+           ; when (has_field_annotations condecl) $
+               failWith $ TcRnTypeDataForbids TypeDataForbidsFieldAnnotations
            }
 
     has_labelled_fields (ConDeclGADT { con_g_args = RecConGADT _ _ }) = True
@@ -2125,13 +2124,19 @@ rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = cond
       = not (null (unLoc flds))
     has_labelled_fields _ = False
 
-    has_strictness_flags condecl
-      = any isSrcStrict (con_arg_bangs condecl)
+    has_field_annotations condecl
+      = not (all unannotated (con_arg_fields condecl))
+      where
+        unannotated (CDF { cdf_bang = NoSrcStrict
+                         , cdf_unpack = NoSrcUnpack
+                         , cdf_multiplicity = HsModifiedFunArr _ [] (HsStandardArr _) })
+          = True
+        unannotated _ = False
 
-    con_arg_bangs (ConDeclGADT { con_g_args = PrefixConGADT _ args }) = map cdf_bang args
-    con_arg_bangs (ConDeclH98 { con_args = PrefixCon _ args }) = map cdf_bang args
-    con_arg_bangs (ConDeclH98 { con_args = InfixCon _ arg1 arg2 }) = [cdf_bang arg1, cdf_bang arg2]
-    con_arg_bangs _ = []
+    con_arg_fields (ConDeclGADT { con_g_args = PrefixConGADT _ args }) = args
+    con_arg_fields (ConDeclH98 { con_args = PrefixCon _ args }) = args
+    con_arg_fields (ConDeclH98 { con_args = InfixCon _ arg1 arg2 }) = [arg1, arg2]
+    con_arg_fields _ = []
 
 {-
 Note [Type data declarations]
@@ -2166,8 +2171,9 @@ preceded by `type`, with the following restrictions:
 (R2) There are no labelled fields.  Perhaps these could be supported
      using type families, but they are omitted for now.
 
-(R3) There are no strictness flags, because they don't make sense at
-     the type level.
+(R3) There are no strictness, unpackedness or multiplicity annotations
+     (!, ~, {-# UNPACK #-}, {-# NOUNPACK #-}, %m ->, ⊸), because they
+     don't make sense at the type level.
 
 (R4) The types of the constructors contain no constraints.
 


=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -2866,6 +2866,12 @@ data TcRnMessage where
        type-data/should_fail/TDRecordsH98
        type-data/should_fail/TDStrictnessGADT
        type-data/should_fail/TDStrictnessH98
+       type-data/should_fail/T27732a
+       type-data/should_fail/T27732b
+       type-data/should_fail/T27732c
+       type-data/should_fail/T27732d
+       type-data/should_fail/T27732e
+       type-data/should_fail/T27732f
   -}
   TcRnTypeDataForbids :: !TypeDataForbids -> TcRnMessage
 
@@ -4541,15 +4547,15 @@ data ZonkerMessage where
 data TypeDataForbids
   = TypeDataForbidsDatatypeContexts
   | TypeDataForbidsLabelledFields
-  | TypeDataForbidsStrictnessAnnotations
+  | TypeDataForbidsFieldAnnotations
   | TypeDataForbidsDerivingClauses
   deriving Generic
 
 instance Outputable TypeDataForbids where
-  ppr TypeDataForbidsDatatypeContexts      = text "Data type contexts"
-  ppr TypeDataForbidsLabelledFields        = text "Labelled fields"
-  ppr TypeDataForbidsStrictnessAnnotations = text "Strictness flags"
-  ppr TypeDataForbidsDerivingClauses       = text "Deriving clauses"
+  ppr TypeDataForbidsDatatypeContexts = text "Data type contexts"
+  ppr TypeDataForbidsLabelledFields   = text "Labelled fields"
+  ppr TypeDataForbidsFieldAnnotations = text "Strictness, unpackedness or multiplicity annotations"
+  ppr TypeDataForbidsDerivingClauses  = text "Deriving clauses"
 
 -- | Specifies which back ends can handle a requested foreign import or export
 type ExpectedBackends = [Backend]


=====================================
docs/users_guide/exts/type_data.rst
=====================================
@@ -33,7 +33,8 @@ either an ordinary algebraic data type or a GADT, prefixed with the keyword
 ``type``, except that it may not contain
 a datatype context (even with :extension:`DatatypeContexts`),
 labelled fields,
-strictness flags, or
+:ref:`strictness <strict-haskell>`, :ref:`unpackedness <unpack-pragma>` or
+:ref:`multiplicity <linear-types>` annotations, or
 a ``deriving`` clause.
 
 The only constraints permitted in the types of constructors are


=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -258,7 +258,7 @@ test('T24893', normal, compile_and_run, ['-O'])
 test('CCallConv', [req_c], compile_and_run, ['CCallConv_c.c'])
 test('T25364', normal, compile_and_run, [''])
 test('T26061', normal, compile_and_run, [''])
-test('T26537', normal, compile_and_run, ['-O2 -fregs-graph'])
+test('T26537', compile_timeout_multiplier(1.5), compile_and_run, ['-O2 -fregs-graph'])
 test('T24016', normal, compile_and_run, ['-O1 -fPIC'])
 test('T27046',
      [ req_cmm


=====================================
testsuite/tests/ghc-api/T25121_status.stdout
=====================================
@@ -15,7 +15,7 @@ X(FunArr) match = NoExtField
 X(ExprWithTySig) match = EpUniToken "::" "\8759"
 X(UntypedSplice) match = NoExtField
 X(ExplicitList) mismatch
-  >>> AnnList
+  >>> ((EpToken "["),(EpToken "]"))
   <<< ((EpToken "'"),(EpToken "["),(EpToken "]"))
 X(ExplicitTuple) mismatch
...
...
...
AnnParen
=====================================
testsuite/tests/type-data/should_fail/T27732a.hs
=====================================
@@ -0,0 +1,4 @@
+{-# LANGUAGE TypeData, LazyFieldAnnotations #-}
+module T27732a where
+
+type data T a = Cons ~a


=====================================
testsuite/tests/type-data/should_fail/T27732a.stderr
=====================================
@@ -0,0 +1,3 @@
+T27732a.hs:4:17: error: [GHC-67297]
+    Strictness, unpackedness or multiplicity annotations are not allowed in type data declarations.
+


=====================================
testsuite/tests/type-data/should_fail/T27732b.hs
=====================================
@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeData, LazyFieldAnnotations #-}
+module T27732b where
+
+type data T a where
+     Cons :: ~a -> T a


=====================================
testsuite/tests/type-data/should_fail/T27732b.stderr
=====================================
@@ -0,0 +1,3 @@
+T27732b.hs:5:6: error: [GHC-67297]
+    Strictness, unpackedness or multiplicity annotations are not allowed in type data declarations.
+


=====================================
testsuite/tests/type-data/should_fail/T27732c.hs
=====================================
@@ -0,0 +1,4 @@
+{-# LANGUAGE TypeData #-}
+module T27732c where
+
+type data T a = Cons {-# UNPACK #-} a


=====================================
testsuite/tests/type-data/should_fail/T27732c.stderr
=====================================
@@ -0,0 +1,3 @@
+T27732c.hs:4:17: error: [GHC-67297]
+    Strictness, unpackedness or multiplicity annotations are not allowed in type data declarations.
+


=====================================
testsuite/tests/type-data/should_fail/T27732d.hs
=====================================
@@ -0,0 +1,4 @@
+{-# LANGUAGE TypeData #-}
+module T27732d where
+
+type data T a = Cons {-# NOUNPACK #-} a


=====================================
testsuite/tests/type-data/should_fail/T27732d.stderr
=====================================
@@ -0,0 +1,3 @@
+T27732d.hs:4:17: error: [GHC-67297]
+    Strictness, unpackedness or multiplicity annotations are not allowed in type data declarations.
+


=====================================
testsuite/tests/type-data/should_fail/T27732e.hs
=====================================
@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeData, LinearTypes #-}
+module T27732e where
+
+type data T where
+  MkT :: Int %1 -> T


=====================================
testsuite/tests/type-data/should_fail/T27732e.stderr
=====================================
@@ -0,0 +1,3 @@
+T27732e.hs:5:3: error: [GHC-67297]
+    Strictness, unpackedness or multiplicity annotations are not allowed in type data declarations.
+


=====================================
testsuite/tests/type-data/should_fail/T27732f.hs
=====================================
@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeData, LinearTypes, UnicodeSyntax #-}
+module T27732f where
+
+type data T where
+  MkT :: Int ⊸ T


=====================================
testsuite/tests/type-data/should_fail/T27732f.stderr
=====================================
@@ -0,0 +1,3 @@
+T27732f.hs:5:3: error: [GHC-67297]
+    Strictness, unpackedness or multiplicity annotations are not allowed in type data declarations.
+


=====================================
testsuite/tests/type-data/should_fail/TDStrictnessGADT.stderr
=====================================
@@ -1,3 +1,3 @@
+TDStrictnessGADT.hs:5:6: error: [GHC-67297]
+    Strictness, unpackedness or multiplicity annotations are not allowed in type data declarations.
 
-TDStrictnessGADT.hs:5:6: [GHC-67297]
-    Strictness flags are not allowed in type data declarations.


=====================================
testsuite/tests/type-data/should_fail/TDStrictnessH98.stderr
=====================================
@@ -1,3 +1,3 @@
+TDStrictnessH98.hs:4:17: error: [GHC-67297]
+    Strictness, unpackedness or multiplicity annotations are not allowed in type data declarations.
 
-TDStrictnessH98.hs:4:17: [GHC-67297]
-    Strictness flags are not allowed in type data declarations.


=====================================
testsuite/tests/type-data/should_fail/all.T
=====================================
@@ -13,3 +13,9 @@ test('TDStrictnessGADT', normal, compile_fail, [''])
 test('TDStrictnessH98', normal, compile_fail, [''])
 test('TDTagToEnum', normal, compile_fail, [''])
 test('T22332b', normal, compile_fail, [''])
+test('T27732a', normal, compile_fail, [''])
+test('T27732b', normal, compile_fail, [''])
+test('T27732c', normal, compile_fail, [''])
+test('T27732d', normal, compile_fail, [''])
+test('T27732e', normal, compile_fail, [''])
+test('T27732f', normal, compile_fail, [''])


=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -140,9 +140,9 @@ defaultEPState = EPState
 
 -- | The R part of RWS. The environment. Updated via 'local' as we
 -- enter a new AST element, having a different anchor point.
-data EPOptions m a = EPOptions
-            { epTokenPrint :: String -> m a
-            , epWhitespacePrint :: String -> m a
+data EPOptions m w = EPOptions
+            { epTokenPrint :: String -> m w
+            , epWhitespacePrint :: String -> m w
             }
 
 -- | Helper to create a 'EPOptions'
@@ -163,8 +163,7 @@ stringOptions = epOptions return return
 deltaOptions :: EPOptions Identity ()
 deltaOptions = epOptions (\_ -> return ()) (\_ -> return ())
 
-data EPWriter a = EPWriter
-              { output :: !a }
+data EPWriter w = EPWriter { output :: !w }
 
 instance Monoid w => Semigroup (EPWriter w) where
   (EPWriter a) <> (EPWriter b) = EPWriter (a <> b)
@@ -239,7 +238,220 @@ setAnchorEpaL (EpAnn _ an _) anc ts cs = EpAnn anc (setTrailing (an {al_anchor =
 -- | Key entry point.  Switches to an independent AST element with its
 -- own annotation, calculating new offsets, etc
 markAnnotated :: (Monad m, Monoid w, ExactPrint a) => a -> EP w m a
-markAnnotated a = enterAnn (getAnnotationEntry a) a
+markAnnotated a = enterAnn (getAnnotationEntry a) a -- See Note [Exact print main loop]
+
+{-
+Note [Exact print main loop]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Exact printing is the process of taking the ParsedSource, or some
+subtree from it, and rendering it to a string, which accurately
+reflects the original source that was parsed, except detail of
+whitespace (such as spaces vs tabs) is discarded.
+
+The ParsedSource or fragment from it must implement the ExactPrint
+class, and this file does that, as well as supporting machinery to
+drive the process. The ExactPrint class is described later in this
+note.
+
+The entry point for exact printing is the exactPrint function, defined
+as
+
+  exactPrint :: ExactPrint ast => ast -> String
+  exactPrint ast = snd $ runIdentity (runEP stringOptions (markAnnotated ast))
+
+  type EP w m a = RWST (EPOptions m w) (EPWriter w) EPState m a
+
+  runEP :: (Monad m) => EPOptions m w -> EP w m a -> m (a, w)
+  runEP epReader action = do
+    (ast, w) <- evalRWST action epReader defaultEPState
+    return (ast, output w)
+
+  data EPWriter w = EPWriter { output :: !w }
+
+  data EPOptions m w = EPOptions
+              { epTokenPrint :: String -> m w
+              , epWhitespacePrint :: String -> m w
+              }
+
+This offers some flexibility in how the output is produced, in that
+the EpWriter and EPOptions work together, defining an output type and
+a function to render whitespace and non-whitepace.
+
+In normal operation (via exactPrint) these are simply returning the
+string unchanged and accumulating a larger string. But it has also been
+used to render an HTML version of the source as it prints.
+
+The main reason exact print exists is to make it easier for tool
+writers to manipulate the ParsedSource, and render this back to the
+original source, except for the changed parts. One manipulation is to
+simply take say a FunBind with its signature from one place in the
+code to another. When doing this, the original parsed locations are no
+longer useful when rendering the source back to a string. To enable
+this, we have another entry point, for converting all absolute
+locations to relative ones, using DeltaPos, which captures the line
+and col offset relative to the prior output.
+
+The function to do this is
+
+  makeDeltaAst :: ExactPrint ast => ast -> ast
+  makeDeltaAst ast = fst $ runIdentity (runEP deltaOptions (markAnnotated ast))
+
+The implementation is practically identical for exactPrint and
+makeDeltaAst, they simply return the second or first part of the same
+calculation.
+
+This simplifies the implementation of the required ExactPrint
+implmentations, in that we only need one per ast item, which encodes
+how to print it, and this print process does bookkeeping to keep track
+of what spacing it used when doing the print, so it can return the
+updated item, with the original absolute SrcSpan's converted to
+DeltaPos values instead.
+
+This information is captured in the XRec/Anno instances used in GHC
+Hs, which are mostly LocatedA a, defined as
+
+  GenLocated (EpAnn [TrailingAnn]) a
+
+  data EpAnn ann
+    = EpAnn { entry   :: !EpaLocation
+            , anns     :: !ann
+            , comments :: !EpAnnComments
+            }
+
+  data EpaLocation = EpaSpan !SrcSpan
+                   | EpaDelta !SrcSpan !DeltaPos [LEpaComment]
+
+When parsed, the entry EpaLocation captures an EpaSpan with the parsed
+absolute location. After makeDeltaAst, this instead uses EpaDelta,
+including the original SrcSpan, the relative spaceing as a DeltaPos,
+and any comments that may come before the item, e.g. comments before a
+semicolon.
+
+Both exactPrint and makeDeltaAst call markAnnotated on the item to be
+printed, inside the monad machinery.
+
+  markAnnotated :: (Monad m, Monoid w, ExactPrint a) => a -> EP w m a
+  markAnnotated a = enterAnn (getAnnotationEntry a) a
+
+This makes use of the ExactPrint instance for the ParsedSource and
+for every other part of the ParsedSource as a tree.
+
+  class (Typeable a) => ExactPrint a where
+    getAnnotationEntry :: a -> Entry
+    exact :: (Monad m, Monoid w) => a -> EP w m a
+    setAnnotationAnchor :: a -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> a
+
+- getAnnotationEntry : returns the Entry information, normally derived
+                       directly from the EpAnn in the LocatedA enclosing the item.
+    Entry contains
+    - The location of the first non-comment part of the item to be printed.
+    - Any [TrailingAnn] (semis, commas, etc) to follow the item.
+    - Any comments associated with the item, but not with enclosed items.
+      These comments may also precede or follow the entry location
+    - Some technical flags, relating to flushing remaining comments at the
+      last (topmost) item, and if the anchor can be updated (see below).
+
+- exact : Do the actual printing of the item, having been put in the right
+  place in terms of print location by the main loop, based on a call to
+  getAnnotationEntry for it. This printing normally comprises making nested
+  markAnnotated calls on the nested items in the current one, e.g.
+
+    exact (HsApp an e1 e2) = do
+      e1' <- markAnnotated e1
+      e2' <- markAnnotated e2
+      return (HsApp an e1' e2')
+
+- setAnnotationAnchor : the main loop printing does two things:
+  - produce output, reflecting the items being printed
+  - convert all the locations in the item (each an EpaLocation) from its
+    EpaSpan version to an EpaDelta one, which is independent of absolute
+    location, being the spacing from the previous print output to this
+    entry point
+  To allow these updated locations to be captured, the item implements
+  the setAnnotationAnchor method, which updates the fields of the Entry
+  returned by getAnnotationEntry
+
+You will recall
+
+  markAnnotated a = enterAnn (getAnnotationEntry a) a
+  enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a
+
+enterAnn is the part that is repeatedly called via markAnnotated, to
+manage the bookkeeping around printing and calculating the updated
+delta positions.
+
+It manages the printing state, adding the new comments from the Entry,
+positioning the print head to the entry point, takes account of whether
+it is an absolute span or a delta, and prints any comments that must come
+before this location.
+
+At this print location, it calls the `exact` method on the item. This
+is the only place `exact` can be called. Within `exact` implementations
+the `markAnnotated` function should be used instead, to ensure the state
+is managed properly for printing.
+
+Once the item is printed via its `exact` method, which normally
+recurses via `markAnnotated` into any nested items inside it, the
+`enterAnn` function prints any [TrailingAnn] from the entry and any
+trailing comments. It then wraps up by calling
+`setAnnotationAnchor`with the updated (now delta-based) values for the
+Entry
+
+Printing Complicated Items
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Sometimes we need to print a sub-item which does not map cleanly onto the
+ExactPrint class, usually because there are parts spread through the item
+that need to be managed together while printing.
+
+An example is in
+https://gitlab.haskell.org/ghc/ghc/-/merge_requests/16321, where
+ConDeclGADT needs to print its inner_bindings, but the these in turn
+may have parens, e.g.
+
+  data V a where
+    MkV4 :: forall a. ((forall b. (Show a => a -> (b -> V a))))
+
+Here there are inner bindings for the first forall, the multiple
+parens around the second forall, and the second forall, wrapping the
+inner content within this.
+
+But the inner content `Show a => a -> (b -> V a)` had to be printed "inside"
+the inner_bindings, to correctly close the nested parens.
+
+The approach in !16321 modified `enterAnn`, to pass in alternate versions
+of the `exact` implementation. This works, but it makes an already
+complicated function even more complicated.
+
+An ExactPrint-idiomatic approach is to create a helper data structure
+to represent this nested organisation, and provide ExactPrint
+instances for that.
+
+This is done in
+https://gitlab.haskell.org/ghc/ghc/-/merge_requests/16644, using
+
+  data InnerBindings
+    = InnerMore (LHsGadtTelescope GhcPs) InnerBindings
+    | InnerDone (Maybe (LHsContext GhcPs), HsConDeclGADTDetails GhcPs, LHsType GhcPs)
+
+The key part of the ExactPrint instance for this is
+
+  exact  (InnerMore (L l (HsGadtPar (lp, rp))) xs) = do
+    lp' <- markEpToken lp
+    xs' <- markAnnotated xs
+    rp' <- markEpToken rp
+    return (InnerMore (L l (HsGadtPar (lp',rp'))) xs')
+
+This first prints the opening paren, prints the balance of the cons list, then
+prints the closing paren.
+
+Conversions to and from this structure populate the initial values from
+the ConDeclGADT, and retrieve the updated delta-based values after
+printing.
+
+Another use of this technique involves HsModuleImpDecls.
+
+-}
 
 -- | For HsModule, because we do not have a proper SrcSpan, we must
 -- indicate to flush trailing comments when done.
@@ -377,6 +589,7 @@ cua NoCanUpdateAnchor _ = return []
 -- This is combination of the ghc=exactprint Delta.withAST and
 -- Print.exactPC functions and effectively does the delta processing
 -- immediately followed by the print processing.  JIT ghc-exactprint.
+-- See Note [Exact print main loop]
 enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a
 enterAnn NoEntryVal a = do
   p <- getPosP
@@ -764,18 +977,12 @@ markLensBracketsO' :: (Monad m, Monoid w)
   => a -> Lens a AnnListBrackets -> EP w m a
 markLensBracketsO' a l =
   case view l a of
-    ListParens o c -> do
-      o' <- markEpToken o
-      return (set l (ListParens o' c) a)
     ListBraces o c -> do
       o' <- markEpToken o
       return (set l (ListBraces o' c) a)
     ListSquare o c -> do
       o' <- markEpToken o
       return (set l (ListSquare o' c) a)
-    ListBanana o c -> do
-      o' <- markEpUniToken o
-      return (set l (ListBanana o' c) a)
     ListNone -> return (set l ListNone a)
 
 markLensBracketsC :: (Monad m, Monoid w)
@@ -786,18 +993,12 @@ markLensBracketsC' :: (Monad m, Monoid w)
   => a -> Lens a AnnListBrackets -> EP w m a
 markLensBracketsC' a l =
   case view l a of
-    ListParens o c -> do
-      c' <- markEpToken c
-      return (set l (ListParens o c') a)
     ListBraces o c -> do
       c' <- markEpToken c
       return (set l (ListBraces o c') a)
     ListSquare o c -> do
       c' <- markEpToken c
       return (set l (ListSquare o c') a)
-    ListBanana o c -> do
-      c' <- markEpUniToken c
-      return (set l (ListBanana o c') a)
     ListNone -> return (set l ListNone a)
 
 -- -------------------------------------
@@ -2919,13 +3120,13 @@ instance ExactPrint (HsExpr GhcPs) where
     (an',l',stmts') <- exactDo (an,l) do_or_list_comp stmts
     return (HsDo (an',l') do_or_list_comp stmts')
 
-  exact (ExplicitList an es) = do
+  exact (ExplicitList (o,c) es) = do
     debugM $ "ExplicitList start"
-    an0 <- markLensBracketsO' an lal_brackets
+    o' <- markEpToken o
     es' <- mapM markAnnotated es
-    an1 <- markLensBracketsC' an0 lal_brackets
+    c' <- markEpToken c
     debugM $ "ExplicitList end"
-    return (ExplicitList an1 es')
+    return (ExplicitList (o',c') es')
   exact (RecordCon x con_id binds) = do
     con_id' <- markAnnotated con_id
     binds' <- markAnnotated binds
@@ -3335,8 +3536,8 @@ instance ExactPrint (HsCmd GhcPs) where
     arr' <- markAnnotated arr
     return (HsCmdArrApp (isU, l') arr' arg' HsHigherOrderApp False)
 
-  exact (HsCmdArrForm an e fixity cs) = do
-    an0 <- markLensBracketsO' an lal_brackets
+  exact (HsCmdArrForm (o,c) e fixity cs) = do
+    o' <- markEpUniToken o
     (e',cs') <- case (fixity, cs) of
       (Infix, (arg1:argrest)) -> do
         arg1' <- markAnnotated arg1
@@ -3348,8 +3549,8 @@ instance ExactPrint (HsCmd GhcPs) where
         cs' <- mapM markAnnotated cs
         return (e', cs')
       (Infix, []) -> error "Not possible"
-    an1 <- markLensBracketsC' an0 lal_brackets
-    return (HsCmdArrForm an1 e' fixity cs')
+    c' <- markEpUniToken c
+    return (HsCmdArrForm (o',c') e' fixity cs')
 
   exact (HsCmdApp an e1 e2) = do
     e1' <- markAnnotated e1
@@ -4671,9 +4872,11 @@ instance ExactPrint (Pat GhcPs) where
     pat' <- markAnnotated pat
     return (BangPat an0 pat')
 
-  exact (ListPat an pats) = do
-    (an', pats') <- markAnnList' an (mapM markAnnotated pats)
-    return (ListPat an' pats')
+  exact (ListPat (os,cs) pats) = do
+    os' <- markEpToken os
+    pats' <- mapM markAnnotated pats
+    cs' <- markEpToken cs
+    return (ListPat (os',cs') pats')
 
   exact (TuplePat an pats boxity) = do
     an0 <- markOpeningParen an


=====================================
utils/check-exact/Utils.hs
=====================================
@@ -342,10 +342,8 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports
         (xs',rest') = allocPreceding xs rest
 
 annListBracketsLocs :: AnnListBrackets -> (EpaLocation,EpaLocation)
-annListBracketsLocs (ListParens o c) = (getEpTokenLoc o,    getEpTokenLoc c)
 annListBracketsLocs (ListBraces o c) = (getEpTokenLoc o,    getEpTokenLoc c)
 annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o,    getEpTokenLoc c)
-annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c)
 annListBracketsLocs ListNone         = (noAnn,              noAnn)
 
 data SplitWhere = Before | After



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

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