Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: a9827d13 by Simon Jakobi at 2026-09-11T18:53:32-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 - - - - - c71d5e23 by Alan Zimmerman at 2026-09-11T18:54:11-04:00 EPA: Add a Note for the exact print main loop - - - - - edfc736b by Simon Jakobi at 2026-09-12T15:25:34-04:00 FastString: Drop mkFastStringWith's constructor callback All three callers passed the same callback, a partial application of mkNewFastStringShortByteString to the string being interned. That partial application is allocated as a closure before the table lookup, on the common hit path too, although the callback is needed only after a miss. Drop the parameter and call mkNewFastStringShortByteString directly after a miss. Since nothing is passed "with" anymore, rename the function to internSB. Suggested by Simon PJ in #27528: https://gitlab.haskell.org/ghc/ghc/-/work_items/27528#note_687031 Assisted-by: Claude Fable 5 - - - - - 95d56c33 by Alan Zimmerman at 2026-09-12T15:25:35-04:00 EPA: More targeted HsDo exact print annotation HsDo is multi-purpose, as encoded in its HsDoFlavour field. Some of these are in a layout context (DoExpr, MDoExpr), others are not (ListComp, MonadComp). We are moving towards using AnnList only in layout contexts, so we switch the HsDo TTG annotation from holding an AnnList for this, to holding Either (EpToken "[", EpToken "]") AnnList This also allows us to trim down AnnListBrackets to only have braces or None, thereby opening the door for unification with the existing layout context data type EpLayout. - - - - - 30 changed files: - + changelog.d/27732 - compiler/GHC/Data/FastString.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Utils.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/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/printer/Test20297.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: ===================================== 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/Data/FastString.hs ===================================== @@ -320,7 +320,7 @@ data FastStringTable = FastStringTable -- ^ Number of computed z-encodings for all buckets. -- -- We mark this as 'NOUNPACK' as this 'FastMutInt' is retained by a thunk - -- in 'mkFastStringWith' and needs to be boxed any way. + -- in 'internSB' and needs to be boxed any way. -- If this is unpacked, then we box this single 'FastMutInt' once for each -- allocated FastString. (Array# (IORef FastStringTableSegment)) -- ^ concurrent segments @@ -474,9 +474,10 @@ The procedure goes like this: * Otherwise, insert and return the string we created. -} -mkFastStringWith - :: (Int -> FastMutInt-> IO FastString) -> ShortByteString -> IO FastString -mkFastStringWith mk_fs sbs = do +-- | Return the interned 'FastString' for the given bytes, creating and +-- inserting one on a table miss. +internSB :: ShortByteString -> IO FastString +internSB sbs = do FastStringTableSegment lock _ buckets# <- readIORef segmentRef let idx# = hashToIndex# buckets# hash# bucket <- IO $ readArray# buckets# idx# @@ -487,7 +488,7 @@ mkFastStringWith mk_fs sbs = do -- only run partially and putMVar is not called after takeMVar. noDuplicate n <- get_uid - new_fs <- mk_fs n n_zencs + new_fs <- mkNewFastStringShortByteString sbs n n_zencs withMVar lock $ \_ -> insert new_fs where !(FastStringTable uid n_zencs segments#) = stringTable @@ -523,11 +524,11 @@ bucket_match fs sbs = go fs mkFastStringBytes :: Ptr Word8 -> Int -> FastString mkFastStringBytes !ptr !len = - -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is + -- NB: Might as well use unsafeDupablePerformIO, since internSB is -- idempotent. unsafeDupablePerformIO $ do sbs <- newSBSFromPtr ptr len - mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + internSB sbs newSBSFromPtr :: Ptr a -> Int -> IO ShortByteString newSBSFromPtr (Ptr src#) (I# len#) = @@ -541,14 +542,13 @@ newSBSFromPtr (Ptr src#) (I# len#) = mkFastStringByteString :: ByteString -> FastString mkFastStringByteString bs = let sbs = SBS.toShort bs in - inlinePerformIO $ - mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + inlinePerformIO $ internSB sbs -- | Create a 'FastString' from an existing 'ShortByteString' without -- copying. mkFastStringShortByteString :: ShortByteString -> FastString mkFastStringShortByteString sbs = - inlinePerformIO $ mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + inlinePerformIO $ internSB sbs -- | Create a 'FastString' from an 'HText' mkFastStringShortText :: ShortText -> FastString @@ -560,7 +560,7 @@ mkFastString :: String -> FastString mkFastString str = inlinePerformIO $ do let !sbs = utf8EncodeShortByteString str - mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + internSB sbs -- The following rule is used to avoid polluting the non-reclaimable FastString -- table with transient strings when we only want their encoding. ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -290,10 +290,12 @@ type instance XLet GhcPs = (EpToken "let", EpToken "in") type instance XLet GhcRn = NoExtField type instance XLet GhcTc = NoExtField -type instance XDo GhcPs = (AnnList, EpaLocation) +type instance XDo GhcPs = DoAnn type instance XDo GhcRn = NoExtField type instance XDo GhcTc = Type +type DoAnn = (Either (EpToken "[", EpToken "]") AnnList, EpaLocation) + type instance XExplicitList GhcPs = (EpToken "[", EpToken "]") type instance XExplicitList GhcRn = NoExtField type instance XExplicitList GhcTc = Type @@ -1467,7 +1469,7 @@ type instance XCmdLet GhcPs = (EpToken "let", EpToken "in") type instance XCmdLet GhcRn = NoExtField type instance XCmdLet GhcTc = NoExtField -type instance XCmdDo GhcPs = (AnnList, EpaLocation) +type instance XCmdDo GhcPs = DoAnn type instance XCmdDo GhcRn = NoExtField type instance XCmdDo GhcTc = Type ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -335,11 +335,10 @@ mkHsIntegral :: IntegralLit GhcPs -> HsOverLit GhcPs mkHsFractional :: FractionalLit GhcPs -> HsOverLit GhcPs mkHsIsString :: SourceText -> HText -> HsOverLit GhcPs mkHsDo :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> HsExpr GhcPs -mkHsDoAnns :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> (AnnList, EpaLocation) -> HsExpr GhcPs +mkHsDoAnns :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> DoAnn -> HsExpr GhcPs mkHsComp :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs -mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs - -> (AnnList, EpaLocation) +mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> DoAnn -> HsExpr GhcPs mkNPat :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpToken "-" ===================================== compiler/GHC/Parser.y ===================================== @@ -3152,19 +3152,15 @@ aexp :: { ECP } return $ ECP $ $2 >>= \ $2 -> mkHsDoPV (comb2 $1 $2) - (stmtlistAnns $2) + (Right $ stmtlistAnns $2, glR $1) (fmap mkModuleNameFS (getDO $1)) - (stmtlistStmts $2) - (glR $1) - (glR $2) } + (stmtlistStmts $2) } | MDO stmtlist {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 -> fmap ecpFromExp $ amsA' (L (comb2 $1 $2) - (mkMDo (stmtlistAnns $2) - (MDoExpr $ fmap mkModuleNameFS (getMDO $1)) - (stmtlistStmts $2) - (glR $1) - (glR $2))) } + (mkHsDoAnns (MDoExpr $ fmap mkModuleNameFS (getMDO $1)) + (stmtlistStmts $2) + (Right $ stmtlistAnns $2, glR $1))) } | 'proc' aexp '->' exp {% (checkPattern <=< runPV) (unECP $2) >>= \ p -> runPV (unECP $4) >>= \ $4@cmd -> @@ -3440,7 +3436,7 @@ list :: { forall b. DisambECP b => SrcSpan -> (EpaLocation, EpaLocation) -> PV ( { \loc (ao,ac) -> checkMonadComp >>= \ ctxt -> unECP $1 >>= \ $1 -> do { t <- addTrailingVbarA $1 (epTok $2) - ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [], noAnn)) + ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (Left $ (EpTok ao, EpTok ac), noAnn)) >>= ecpFromExp' } } lexps :: { forall b. DisambECP b => PV [LocatedA b] } @@ -3658,11 +3654,13 @@ apat : aexp {% (checkPattern <=< runPV) (unECP $1) } ----------------------------------------------------------------------------- -- Statement sequences -stmtlist :: { forall b. DisambECP b => PV (LocatedA ((EpToken "{", [EpToken ";"], EpToken "}"), Located [LocatedA (Stmt GhcPs (LocatedA b))])) } +stmtlist :: { forall b. DisambECP b => PV (LocatedA (AnnList, Located [LocatedA (Stmt GhcPs (LocatedA b))])) } : '{' stmts '}' { $2 >>= \ $2 -> - amsA' (sLL $1 $> ((epTok $1, fromOL $ fst $ unLoc $2, epTok $3), sL1 $2 $ reverse $ snd $ unLoc $2))} + amsA' (sLL $1 $> (AnnList (Just (spanAsAnchor $ stmtsLoc $2)) (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2) + , sL1 $2 $ reverse $ snd $ unLoc $2))} | vocurly stmts close { $2 >>= \ $2 -> - amsA' (L (stmtsLoc $2) ((noEpTok, fromOL $ fst $ unLoc $2, noEpTok), sL1 $2 $ reverse $ snd $ unLoc $2))} + amsA' (L (stmtsLoc $2) (AnnList (Just (spanAsAnchor $ stmtsLoc $2)) ListNone (fromOL $ fst $ unLoc $2) + , sL1 $2 $ reverse $ snd $ unLoc $2))} -- do { ;; s ; s ; ; s ;; } -- The last Stmt should be an expression, but that's hard to enforce @@ -3704,7 +3702,7 @@ e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) } stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) } : qual { $1 } | 'rec' stmtlist { $2 >>= \ $2 -> - amsA' (sLL $1 $> $ mkRecStmt (hsDoAnn (epTok $1) (stmtlistAnns $2) $2) + amsA' (sLL $1 $> $ mkRecStmt (stmtlistAnns $2, epTok $1) (stmtlistStmts $2)) } qual :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) } @@ -4724,10 +4722,6 @@ commentsPA la@(L l a) = do !cs <- getPriorCommentsFor (getLocA la) return (L (addCommentsToEpAnn l cs) a) -hsDoAnn :: EpToken "rec" -> (EpToken "{", [EpToken ";"], EpToken "}") -> LocatedAn t b -> (AnnList, EpToken "rec") -hsDoAnn rec (ob, semis, cb) (L ll _) - = (AnnList (Just $ spanAsAnchor (locA ll)) (ListBraces ob cb) semis, rec) - listAsAnchorM :: [LocatedAn t a] -> Maybe EpaLocation listAsAnchorM [] = Nothing listAsAnchorM (L l _:_) = @@ -4757,8 +4751,7 @@ stmtlistStmts :: LocatedA (a, Located [LocatedA (Stmt GhcPs (LocatedA b))]) stmtlistStmts (L la (_,L l stmts)) = L ((noAnnSrcSpan l) {comments = comments la}) stmts -stmtlistAnns :: LocatedA ((EpToken "{", [EpToken ";"], EpToken "}"), a) - -> (EpToken "{", [EpToken ";"], EpToken "}") +stmtlistAnns :: LocatedA (AnnList, a) -> AnnList stmtlistAnns (L _ (an,_)) = an -- ------------------------------------- ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -519,8 +519,7 @@ data AnnList } deriving (Data,Eq) data AnnListBrackets - = ListBraces (EpToken "{") (EpToken "}") - | ListSquare (EpToken "[") (EpToken "]") + = ListBraces (EpToken "{") (EpToken "}") | ListNone deriving (Data,Eq) @@ -1093,7 +1092,6 @@ instance Outputable AnnList where instance Outputable AnnListBrackets where ppr (ListBraces o c) = text "ListBraces" <+> ppr o <+> ppr c - ppr (ListSquare o c) = text "ListSquare" <+> ppr o <+> ppr c ppr ListNone = text "ListNone" instance Outputable AnnCType where ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -12,7 +12,7 @@ module GHC.Parser.PostProcess ( mkRdrGetField, mkRdrProjection, Fbind, -- RecordDot mkHsOpApp, mkHsIntegral, mkHsFractional, mkHsIsString, - mkHsDo, mkMDo, mkSpliceDecl, + mkHsDo, mkSpliceDecl, mkRoleAnnotDecl, mkClassDecl, mkTyData, mkDataFamInst, @@ -435,10 +435,6 @@ mkRoleAnnotDecl loc tycon roles anns addFatalError $ mkPlainErrorMsgEnvelope loc_role $ (PsErrIllegalRoleName role nearby) -mkMDo :: (EpToken "{", [EpToken ";"], EpToken "}") -> HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs -mkMDo (ob, semis, cb) ctxt stmts tok loc - = mkHsDoAnns ctxt stmts (AnnList (Just loc) (ListBraces ob cb) semis, tok) - -- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to -- binders without annotations. Only accepts specified variables, and errors if -- any of the provided binders has an 'InferredSpec' annotation. @@ -1804,12 +1800,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where -> PV (LocatedA b) -- | Disambiguate "do { ... }" (do notation) mkHsDoPV :: - SrcSpan -> - (EpToken "{", [EpToken ";"], EpToken "}") -> - Maybe ModuleName -> - LocatedA [LStmt GhcPs (LocatedA b)] -> - EpaLocation -> -- Token - EpaLocation -> -- Anchor + SrcSpan -> DoAnn -> Maybe ModuleName -> LocatedA [LStmt GhcPs (LocatedA b)] -> PV (LocatedA b) -- | Disambiguate "( ... )" (parentheses) mkHsParPV :: SrcSpan -> EpToken "(" -> LocatedA b -> EpToken ")" -> PV (LocatedA b) @@ -1959,10 +1950,10 @@ instance DisambECP (HsCmd GhcPs) where checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns) - mkHsDoPV l (ob,semis,cb) Nothing stmts tok_loc anc = do + mkHsDoPV l ann Nothing stmts = do !cs <- getCommentsFor l - return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) (ListBraces ob cb) semis, tok_loc) stmts) - mkHsDoPV l _ (Just m) _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo ann stmts) + mkHsDoPV l _ (Just m) _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m mkHsParPV l lpar c rpar = do !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdPar (lpar, rpar) c) @@ -2058,9 +2049,9 @@ instance DisambECP (HsExpr GhcPs) where checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns) - mkHsDoPV l (ob,semis,cb) mod stmts loc_tok anc = do + mkHsDoPV l ann mod stmts = do !cs <- getCommentsFor l - return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) (ListBraces ob cb) semis, loc_tok) (DoExpr mod) stmts) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo ann (DoExpr mod) stmts) mkHsParPV l lpar e rpar = do !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e) @@ -2156,7 +2147,7 @@ instance DisambECP (PatBuilder GhcPs) where !cs <- getCommentsFor (locA l) return $ L (addCommentsToEpAnn l cs) (PatBuilderAppType p at (mkHsTyPat t)) mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat - mkHsDoPV l _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat + mkHsDoPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar) mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v) mkHsLitPV lit@(L l a) = do ===================================== 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/parser/should_compile/DumpParsedAstComments.stderr ===================================== @@ -289,13 +289,12 @@ { DumpParsedAstComments.hs:14:7-8 }))])) (HsDo ((,) - (AnnList - (Just - (EpaSpan { DumpParsedAstComments.hs:16:3 })) - (ListBraces - (EpTok (EpaSpan { <no location info> })) - (EpTok (EpaSpan { <no location info> }))) - []) + (Right + (AnnList + (Just + (EpaSpan { DumpParsedAstComments.hs:16:3 })) + (ListNone) + [])) (EpaSpan { DumpParsedAstComments.hs:14:7-8 })) (DoExpr (Nothing)) ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -331,13 +331,12 @@ [])) (HsDo ((,) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:(11,3)-(12,3) })) - (ListBraces - (EpTok (EpaSpan { <no location info> })) - (EpTok (EpaSpan { <no location info> }))) - []) + (Right + (AnnList + (Just + (EpaSpan { DumpSemis.hs:(11,3)-(12,3) })) + (ListNone) + [])) (EpaSpan { DumpSemis.hs:10:7-8 })) (DoExpr (Nothing)) @@ -363,20 +362,21 @@ [])) (HsDo ((,) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:11:6-15 })) - (ListBraces - (EpTok (EpaSpan { DumpSemis.hs:11:6 })) - (EpTok (EpaSpan { DumpSemis.hs:11:15 }))) - [(EpTok - (EpaSpan { DumpSemis.hs:11:8 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:11:9 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:11:10 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:11:11 }))]) + (Right + (AnnList + (Just + (EpaSpan { DumpSemis.hs:11:8-13 })) + (ListBraces + (EpTok (EpaSpan { DumpSemis.hs:11:6 })) + (EpTok (EpaSpan { DumpSemis.hs:11:15 }))) + [(EpTok + (EpaSpan { DumpSemis.hs:11:8 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:11:9 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:11:10 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:11:11 }))])) (EpaSpan { DumpSemis.hs:11:3-4 })) (DoExpr (Nothing)) @@ -625,16 +625,17 @@ [])) (HsDo ((,) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:(16,3)-(19,3) })) - (ListBraces - (EpTok (EpaSpan { DumpSemis.hs:16:3 })) - (EpTok (EpaSpan { DumpSemis.hs:19:3 }))) - [(EpTok - (EpaSpan { DumpSemis.hs:16:5 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:16:8 }))]) + (Right + (AnnList + (Just + (EpaSpan { DumpSemis.hs:(16,5)-(18,5) })) + (ListBraces + (EpTok (EpaSpan { DumpSemis.hs:16:3 })) + (EpTok (EpaSpan { DumpSemis.hs:19:3 }))) + [(EpTok + (EpaSpan { DumpSemis.hs:16:5 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:16:8 }))])) (EpaSpan { DumpSemis.hs:15:7-8 })) (DoExpr (Nothing)) @@ -877,16 +878,17 @@ [])) (HsDo ((,) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:22:10-30 })) - (ListBraces - (EpTok (EpaSpan { DumpSemis.hs:22:10 })) - (EpTok (EpaSpan { DumpSemis.hs:22:30 }))) - [(EpTok - (EpaSpan { DumpSemis.hs:22:12 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:22:13 }))]) + (Right + (AnnList + (Just + (EpaSpan { DumpSemis.hs:22:12-28 })) + (ListBraces + (EpTok (EpaSpan { DumpSemis.hs:22:10 })) + (EpTok (EpaSpan { DumpSemis.hs:22:30 }))) + [(EpTok + (EpaSpan { DumpSemis.hs:22:12 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:22:13 }))])) (EpaSpan { DumpSemis.hs:22:7-8 })) (DoExpr (Nothing)) ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -394,13 +394,12 @@ [])) (HsDo ((,) - (AnnList - (Just - (EpaSpan { Test20297.hs:11:22-26 })) - (ListBraces - (EpTok (EpaSpan { <no location info> })) - (EpTok (EpaSpan { <no location info> }))) - []) + (Right + (AnnList + (Just + (EpaSpan { Test20297.hs:11:22-26 })) + (ListNone) + [])) (EpaSpan { Test20297.hs:11:19-20 })) (DoExpr (Nothing)) @@ -820,13 +819,12 @@ [])) (HsDo ((,) - (AnnList - (Just - (EpaSpan { Test20297.ppr.hs:9:20-24 })) - (ListBraces - (EpTok (EpaSpan { <no location info> })) - (EpTok (EpaSpan { <no location info> }))) - []) + (Right + (AnnList + (Just + (EpaSpan { Test20297.ppr.hs:9:20-24 })) + (ListNone) + [])) (EpaSpan { Test20297.ppr.hs:9:17-18 })) (DoExpr (Nothing)) ===================================== 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 @@ -767,9 +980,6 @@ markLensBracketsO' a l = 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) ListNone -> return (set l ListNone a) markLensBracketsC :: (Monad m, Monoid w) @@ -783,9 +993,6 @@ markLensBracketsC' a l = 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) ListNone -> return (set l ListNone a) -- ------------------------------------- @@ -1255,6 +1462,19 @@ markKwT (AddDarrowAnn tok) = AddDarrowAnn <$> markEpUniToken tok -- --------------------------------------------------------------------- +markAnnListD :: (Monad m, Monoid w) + => Either (EpToken "[", EpToken "]") AnnList + -> EP w m a + -> EP w m (Either (EpToken "[", EpToken "]") AnnList, a) +markAnnListD (Left (o,c)) action = do + o' <- markEpToken o + r <- action + c' <- markEpToken c + return (Left (o',c'), r) +markAnnListD (Right ann) action = do + (ann',r) <- markAnnList' ann action + return (Right ann',r) + markAnnList :: (Monad m, Monoid w) => EpAnn AnnList -> EP w m a -> EP w m (EpAnn AnnList, a) markAnnList ann action = do @@ -2902,10 +3122,10 @@ instance ExactPrint (HsExpr GhcPs) where e' <- markAnnotated e return (HsLet (tkLet',tkIn') binds' e') - exact (HsDo (an,l) do_or_list_comp stmts) = do + exact (HsDo an do_or_list_comp stmts) = do debugM $ "HsDo" - (an',l',stmts') <- exactDo (an,l) do_or_list_comp stmts - return (HsDo (an',l') do_or_list_comp stmts') + (an',stmts') <- exactDo an do_or_list_comp stmts + return (HsDo an' do_or_list_comp stmts') exact (ExplicitList (o,c) es) = do debugM $ "ExplicitList start" @@ -3077,8 +3297,8 @@ instance ExactPrint (HsExpr GhcPs) where -- --------------------------------------------------------------------- exactDo :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) - => (AnnList, EpaLocation) -> HsDoFlavour -> LocatedAn an a - -> EP w m (AnnList, EpaLocation, LocatedAn an a) + => DoAnn -> HsDoFlavour -> LocatedAn an a + -> EP w m (DoAnn, LocatedAn an a) exactDo (an,l) (DoExpr m) stmts = exactMdo l m "do" >>= \l0 -> markMaybeDodgyStmts (an,l0) stmts exactDo (an,l) GhciStmtCtxt stmts = printStringAtAA l "do" >>= @@ -3097,15 +3317,23 @@ exactMdo l (Just module_name) kw = printStringAtAA l n n = (moduleNameString module_name) ++ "." ++ kw markMaybeDodgyStmts :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) - => (AnnList, EpaLocation) -> LocatedAn an a -> EP w m (AnnList, EpaLocation, LocatedAn an a) + => DoAnn -> LocatedAn an a -> EP w m (DoAnn, LocatedAn an a) markMaybeDodgyStmts (an,l) stmts = if notDodgy stmts then do - (an0,stmts') <- markAnnListA' an $ \a -> do - r <- markAnnotatedWithLayout stmts - return (a, r) - return (an0, l, stmts') - else return (an, l, stmts) + (an0,stmts') <- case an of + Left (o,c) -> do + o' <- markEpToken o + r <- markAnnotated stmts + c' <- markEpToken c + return (Left (o',c'), r) + Right an' -> do + (an'',r') <- markAnnListA' an' $ \a -> do + r <- markAnnotatedWithLayout stmts + return (a, r) + return (Right an'',r') + return ((an0, l), stmts') + else return ((an, l), stmts) notDodgy :: GenLocated (EpAnn ann) a -> Bool notDodgy (L (EpAnn anc _ _) _) = notDodgyE anc @@ -3388,9 +3616,7 @@ instance ExactPrint (HsCmd GhcPs) where exact (HsCmdDo (an0,loc) es) = do debugM $ "HsCmdDo" loc' <- printStringAtAA loc "do" - (an1,es') <- markAnnList' an0 $ do - ee <- markAnnotated es - return ee + (an1,es') <- markAnnListD an0 $ do markAnnotated es return (HsCmdDo (an1,loc') es') -- --------------------------------------------------------------------- ===================================== utils/check-exact/Utils.hs ===================================== @@ -343,7 +343,6 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports annListBracketsLocs :: AnnListBrackets -> (EpaLocation,EpaLocation) annListBracketsLocs (ListBraces o c) = (getEpTokenLoc o, getEpTokenLoc c) -annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c) annListBracketsLocs ListNone = (noAnn, noAnn) data SplitWhere = Before | After View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/da7bb24918f5cdc32e34a444a055f29... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/da7bb24918f5cdc32e34a444a055f29... 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