[Git][ghc/ghc][wip/az/ghc-9.8-backports] 6 commits: ghcup-metadata: Fix date modifier (M = minutes, m = month)
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Tue Aug 29 20:29:30 UTC 2023
Alan Zimmerman pushed to branch wip/az/ghc-9.8-backports at Glasgow Haskell Compiler / GHC
Commits:
cfb98b12 by Matthew Pickering at 2023-08-24T14:04:24-04:00
ghcup-metadata: Fix date modifier (M = minutes, m = month)
Fixes #23552
(cherry picked from commit 43b66a132ad0e6b14e191f27c2599832850e05f2)
- - - - -
51479a69 by Alan Zimmerman at 2023-08-24T16:51:56-04:00
EPA: Keep track of "in" token for WarningTxt category
A warning can now be written with a category, e.g.
{-# WARNInG in "x-c" e "d" #-}
Keep track of the location of the 'in' keyword and string, as well as
the original SourceText of the label, in case it uses character escapes.
(cherry picked from commit 818f8aec7c9a6e037c264f1e2cce16960da8fa24)
- - - - -
249aa819 by Ben Gamari at 2023-08-24T16:51:56-04:00
Bump text submodule to 2.1.0-pre
- - - - -
81db45ab by Alan Zimmerman at 2023-08-29T20:24:25+01:00
EPA: Incorrect locations for UserTyVar with '@'
In T13343.hs, the location for the @ is not within the span of the
surrounding UserTyVar.
type Bad @v = (forall (v1 :: RuntimeRep) (a1 :: TYPE v). a1) :: TYPE v
Widen it so it is captured.
Closes #23887
Note: AZ MR commit, not merged one. update.
(cherry picked from commit 75407f4f01f29e28774c10fbb3733bc808d3a69b)
- - - - -
504fc9fa by Alan Zimmerman at 2023-08-29T20:24:25+01:00
EPA: Incorrect span for LWarnDec GhcPs
The code (from T23465.hs)
{-# WARNInG in "x-c" e "d" #-}
e = e
gives an incorrect span for the LWarnDecl GhcPs
Closes #23892
It also fixes the Test23465/Test23464 mixup
Note: this is from the MR, needs to be updated once it lands
(cherry picked from commit 0674ad4e0a898d9c1bff98f4f25b7c0fcccca0a7)
- - - - -
5d5efbd4 by Alan Zimmerman at 2023-08-29T21:28:58+01:00
EPA: track unicode version for unrestrictedFunTyCon
Closes #23885
Updates haddock submodule
Note: cherry picked from the MR commit, update once it lands
(cherry picked from commit bdd82ccc9fc6f0d45816e7d5ce889759cd8dc4c0)
- - - - -
23 changed files:
- .gitlab-ci.yml
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Unit/Module/Warnings.hs
- compiler/Language/Haskell/Syntax/Concrete.hs
- libraries/text
- testsuite/tests/printer/Makefile
- − testsuite/tests/printer/Test23464.hs
- + testsuite/tests/printer/Test23465.hs
- + testsuite/tests/printer/Test23885.hs
- + testsuite/tests/printer/Test23887.hs
- testsuite/tests/printer/all.T
- testsuite/tests/warnings/should_compile/T23465.hs
- testsuite/tests/warnings/should_compile/T23465.stderr
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/haddock
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -1061,7 +1061,7 @@ ghcup-metadata-nightly:
artifacts: false
- job: project-version
script:
- - nix shell --extra-experimental-features nix-command -f .gitlab/rel_eng -c ghcup-metadata --metadata ghcup-0.0.7.yaml --date="$(date -d $CI_PIPELINE_CREATED_AT +%Y-%M-%d)" --pipeline-id="$CI_PIPELINE_ID" --version="$ProjectVersion" > "metadata_test.yaml"
+ - nix shell --extra-experimental-features nix-command -f .gitlab/rel_eng -c ghcup-metadata --metadata ghcup-0.0.7.yaml --date="$(date -d $CI_PIPELINE_CREATED_AT +%Y-%m-%d)" --pipeline-id="$CI_PIPELINE_ID" --version="$ProjectVersion" > "metadata_test.yaml"
rules:
- if: $NIGHTLY
@@ -1099,7 +1099,7 @@ ghcup-metadata-release:
# No explicit needs for release pipeline as we assume we need everything and everything will pass.
extends: .ghcup-metadata
script:
- - nix shell --extra-experimental-features nix-command -f .gitlab/rel_eng -c ghcup-metadata --release-mode --metadata ghcup-0.0.7.yaml --date="$(date -d $CI_PIPELINE_CREATED_AT +%Y-%M-%d)" --pipeline-id="$CI_PIPELINE_ID" --version="$ProjectVersion" > "metadata_test.yaml"
+ - nix shell --extra-experimental-features nix-command -f .gitlab/rel_eng -c ghcup-metadata --release-mode --metadata ghcup-0.0.7.yaml --date="$(date -d $CI_PIPELINE_CREATED_AT +%Y-%m-%d)" --pipeline-id="$CI_PIPELINE_ID" --version="$ProjectVersion" > "metadata_test.yaml"
rules:
- if: '$RELEASE_JOB == "yes"'
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1220,7 +1220,7 @@ type instance XXWarnDecl (GhcPass _) = DataConCantHappen
instance OutputableBndrId p
=> Outputable (WarnDecls (GhcPass p)) where
ppr (Warnings ext decls)
- = ftext src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"
+ = ftext src <+> vcat (punctuate semi (map ppr decls)) <+> text "#-}"
where src = case ghcPass @p of
GhcPs | (_, SourceText src) <- ext -> src
GhcRn | SourceText src <- ext -> src
@@ -1235,7 +1235,7 @@ instance OutputableBndrId p
<+> ppr txt
where
ppr_category = case txt of
- WarningTxt (Just cat) _ _ -> text "in" <+> doubleQuotes (ppr cat)
+ WarningTxt (Just cat) _ _ -> ppr cat
_ -> empty
{-
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -439,9 +439,12 @@ hsScopedKvs (L _ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndr
hsScopedKvs _ = []
---------------------
+hsTyVarLName :: HsTyVarBndr flag (GhcPass p) -> LIdP (GhcPass p)
+hsTyVarLName (UserTyVar _ _ n) = n
+hsTyVarLName (KindedTyVar _ _ n _) = n
+
hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
-hsTyVarName (UserTyVar _ _ (L _ n)) = n
-hsTyVarName (KindedTyVar _ _ (L _ n) _) = n
+hsTyVarName = unLoc . hsTyVarLName
hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsLTyVarName = hsTyVarName . unLoc
@@ -459,10 +462,12 @@ hsAllLTyVarNames (HsQTvs { hsq_ext = kvs
, hsq_explicit = tvs })
= kvs ++ hsLTyVarNames tvs
-hsLTyVarLocName :: LHsTyVarBndr flag (GhcPass p) -> LocatedN (IdP (GhcPass p))
-hsLTyVarLocName (L l a) = L (l2l l) (hsTyVarName a)
+hsLTyVarLocName :: Anno (IdGhcP p) ~ SrcSpanAnnN
+ => LHsTyVarBndr flag (GhcPass p) -> LocatedN (IdP (GhcPass p))
+hsLTyVarLocName (L _ a) = hsTyVarLName a
-hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]
+hsLTyVarLocNames :: Anno (IdGhcP p) ~ SrcSpanAnnN
+ => LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]
hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
-- | Get the kind signature of a type, ignoring parentheses:
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -403,7 +403,7 @@ toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds'
ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds]
toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt
-toIfaceWarningTxt (WarningTxt mb_cat src strs) = IfWarningTxt (unLoc <$> mb_cat) (unLoc src) (map (toIfaceStringLiteralWithNames . unLoc) strs)
+toIfaceWarningTxt (WarningTxt mb_cat src strs) = IfWarningTxt (unLoc . iwc_wc . unLoc <$> mb_cat) (unLoc src) (map (toIfaceStringLiteralWithNames . unLoc) strs)
toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt (unLoc src) (map (toIfaceStringLiteralWithNames . unLoc) strs)
toIfaceStringLiteralWithNames :: WithHsDocIdentifiers StringLiteral GhcRn -> (IfaceStringLiteral, [IfExtName])
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -590,7 +590,7 @@ fromIfaceWarnings = \case
fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn
fromIfaceWarningTxt = \case
- IfWarningTxt mb_cat src strs -> WarningTxt (noLoc <$> mb_cat) (noLoc src) (noLoc <$> map fromIfaceStringLiteralWithNames strs)
+ IfWarningTxt mb_cat src strs -> WarningTxt (noLoc . fromWarningCategory <$> mb_cat) (noLoc src) (noLoc <$> map fromIfaceStringLiteralWithNames strs)
IfDeprecatedTxt src strs -> DeprecatedTxt (noLoc src) (noLoc <$> map fromIfaceStringLiteralWithNames strs)
fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn
=====================================
compiler/GHC/Parser.y
=====================================
@@ -773,9 +773,9 @@ identifier :: { LocatedN RdrName }
| qvarop { $1 }
| qconop { $1 }
| '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
+ (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) }
| '->' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnnRArrow (glAA $1) []) }
+ (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) }
-----------------------------------------------------------------------------
-- Backpack stuff
@@ -1986,8 +1986,9 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.
-----------------------------------------------------------------------------
-- Warnings and deprecations (c.f. rules)
-warning_category :: { Maybe (Located WarningCategory) }
- : 'in' STRING { Just (sL1 $2 (mkWarningCategory (getSTRING $2))) }
+warning_category :: { Maybe (Located InWarningCategory) }
+ : 'in' STRING { Just (sLL $1 $> $ InWarningCategory (hsTok' $1) (getSTRINGs $2)
+ (sL1 $2 $ mkWarningCategory (getSTRING $2))) }
| {- empty -} { Nothing }
warnings :: { OrdList (LWarnDecl GhcPs) }
@@ -2009,8 +2010,8 @@ warnings :: { OrdList (LWarnDecl GhcPs) }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
warning :: { OrdList (LWarnDecl GhcPs) }
: warning_category namelist strings
- {% fmap unitOL $ acsA (\cs -> sLL $2 $>
- (Warning (EpAnn (glR $2) (fst $ unLoc $3) cs) (unLoc $2)
+ {% fmap unitOL $ acsA (\cs -> L (comb3M $1 $2 $3)
+ (Warning (EpAnn (glMR $1 $2) (fst $ unLoc $3) cs) (unLoc $2)
(WarningTxt $1 (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }
deprecations :: { OrdList (LWarnDecl GhcPs) }
@@ -3664,7 +3665,7 @@ ntgtycon :: { LocatedN RdrName } -- A "general" qualified tycon, excluding unit
| '(#' bars '#)' {% amsrn (sLL $1 $> $ getRdrName (sumTyCon (snd $2 + 1)))
(NameAnnBars NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }
| '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
+ (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) }
| '[' ']' {% amsrn (sLL $1 $> $ listTyCon_RDR)
(NameAnnOnly NameSquare (glAA $1) (glAA $2) []) }
@@ -3746,7 +3747,8 @@ otycon :: { LocatedN RdrName }
op :: { LocatedN RdrName } -- used in infix decls
: varop { $1 }
| conop { $1 }
- | '->' { sL1n $1 $ getRdrName unrestrictedFunTyCon }
+ | '->' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
+ (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) }
varop :: { LocatedN RdrName }
: varsym { $1 }
@@ -4112,6 +4114,12 @@ comb3N :: Located a -> Located b -> LocatedN c -> SrcSpan
comb3N a b c = a `seq` b `seq` c `seq`
combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c))
+comb3M :: Maybe (Located a) -> Located b -> Located c -> SrcSpan
+comb3M (Just a) b c = a `seq` b `seq` c `seq`
+ combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))
+comb3M Nothing b c = b `seq` c `seq`
+ (combineSrcSpans (getLoc b) (getLoc c))
+
comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan
comb4 a b c d = a `seq` b `seq` c `seq` d `seq`
(combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $
@@ -4342,6 +4350,10 @@ glN = getLocA
glR :: Located a -> Anchor
glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor
+glMR :: Maybe (Located a) -> Located b -> Anchor
+glMR (Just la) _ = glR la
+glMR _ la = glR la
+
glAA :: Located a -> EpaLocation
glAA = srcSpan2e . getLoc
@@ -4494,6 +4506,9 @@ listAsAnchor (L l _:_) = spanAsAnchor (locA l)
hsTok :: Located Token -> LHsToken tok GhcPs
hsTok (L l _) = L (mkTokenLocation l) HsTok
+hsTok' :: Located Token -> Located (HsToken tok)
+hsTok' (L l _) = L l HsTok
+
hsUniTok :: Located Token -> LHsUniToken tok utok GhcPs
hsUniTok t@(L l _) =
L (mkTokenLocation l)
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -757,7 +757,10 @@ data NameAnn
}
-- | Used for @->@, as an identifier
| NameAnnRArrow {
+ nann_unicode :: Bool,
+ nann_mopen :: Maybe EpaLocation,
nann_name :: EpaLocation,
+ nann_mclose :: Maybe EpaLocation,
nann_trailing :: [TrailingAnn]
}
-- | Used for an item with a leading @'@. The annotation for
@@ -920,7 +923,7 @@ realSrcSpan :: SrcSpan -> RealSrcSpan
realSrcSpan (RealSrcSpan s _) = s
realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary
where
- l = mkRealSrcLoc (fsLit "foo") (-1) (-1)
+ l = mkRealSrcLoc (fsLit "realSrcSpan") (-1) (-1)
srcSpan2e :: SrcSpan -> EpaLocation
srcSpan2e (RealSrcSpan s mb) = EpaSpan s mb
@@ -1288,8 +1291,8 @@ instance Outputable NameAnn where
= text "NameAnnBars" <+> ppr a <+> ppr o <+> ppr n <+> ppr b <+> ppr t
ppr (NameAnnOnly a o c t)
= text "NameAnnOnly" <+> ppr a <+> ppr o <+> ppr c <+> ppr t
- ppr (NameAnnRArrow n t)
- = text "NameAnnRArrow" <+> ppr n <+> ppr t
+ ppr (NameAnnRArrow u o n c t)
+ = text "NameAnnRArrow" <+> ppr u <+> ppr o <+> ppr n <+> ppr c <+> ppr t
ppr (NameAnnQuote q n t)
= text "NameAnnQuote" <+> ppr q <+> ppr n <+> ppr t
ppr (NameAnnTrailing t)
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -912,19 +912,30 @@ checkTyVars pp_what equals_or_where tc tparms
= let
an = (reverse ops) ++ cps
in
- return (L (widenLocatedAn (l Semi.<> annt) an)
- (KindedTyVar (addAnns (annk Semi.<> ann) an cs) bvis (L lv tv) k))
+ return (L (widenLocatedAn (l Semi.<> annt) (for_widening bvis:an))
+ (KindedTyVar (addAnns (annk Semi.<> ann Semi.<> for_widening_ann bvis) an cs)
+ bvis (L lv tv) k))
chk ops cps cs bvis (L l (HsTyVar ann _ (L ltv tv)))
| isRdrTyVar tv
= let
an = (reverse ops) ++ cps
in
- return (L (widenLocatedAn l an)
- (UserTyVar (addAnns ann an cs) bvis (L ltv tv)))
+ return (L (widenLocatedAn l (for_widening bvis:an))
+ (UserTyVar (addAnns (ann Semi.<> for_widening_ann bvis) an cs)
+ bvis (L ltv tv)))
chk _ _ _ _ t@(L loc _)
= addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
(PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where)
+ -- Return an AddEpAnn for use in widenLocatedAn. The AnnKeywordId is not used.
+ for_widening :: HsBndrVis GhcPs -> AddEpAnn
+ for_widening (HsBndrInvisible (L (TokenLoc loc) _)) = AddEpAnn AnnAnyclass loc
+ for_widening _ = AddEpAnn AnnAnyclass (EpaDelta (SameLine 0) [])
+
+ for_widening_ann :: HsBndrVis GhcPs -> EpAnn [AddEpAnn]
+ for_widening_ann (HsBndrInvisible (L (TokenLoc (EpaSpan r _mb)) _)) = EpAnn (realSpanAsAnchor r) [] emptyComments
+ for_widening_ann _ = EpAnnNotUsed
+
whereDots, equalsDots :: SDoc
-- Second argument to checkTyVars
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -300,7 +300,7 @@ rnSrcWarnDecls bndr_set decls'
rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn)
rnWarningTxt (WarningTxt mb_cat st wst) = do
- forM_ mb_cat $ \(L loc cat) ->
+ forM_ mb_cat $ \(L _ (InWarningCategory _ _ (L loc cat))) ->
unless (validWarningCategory cat) $
addErrAt loc (TcRnInvalidWarningCategory cat)
wst' <- traverse (traverse rnHsDoc) wst
=====================================
compiler/GHC/Unit/Module/Warnings.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -10,10 +11,12 @@
-- | Warnings for a module
module GHC.Unit.Module.Warnings
- ( WarningCategory
+ ( WarningCategory(..)
, mkWarningCategory
, defaultWarningCategory
, validWarningCategory
+ , InWarningCategory(..)
+ , fromWarningCategory
, WarningCategorySet
, emptyWarningCategorySet
@@ -56,6 +59,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Binary
import GHC.Unicode
+import Language.Haskell.Syntax.Concrete (HsToken (HsTok))
import Language.Haskell.Syntax.Extension
import Data.Data
@@ -110,6 +114,15 @@ the possibility of them being infinite.
-}
+data InWarningCategory
+ = InWarningCategory
+ { iwc_in :: !(Located (HsToken "in")),
+ iwc_st :: !SourceText,
+ iwc_wc :: (Located WarningCategory)
+ } deriving Data
+
+fromWarningCategory :: WarningCategory -> InWarningCategory
+fromWarningCategory wc = InWarningCategory (noLoc HsTok) NoSourceText (noLoc wc)
-- See Note [Warning categories]
@@ -184,7 +197,7 @@ deleteWarningCategorySet c (CofiniteWarningCategorySet s) = CofiniteWarningCateg
-- reason/explanation from a WARNING or DEPRECATED pragma
data WarningTxt pass
= WarningTxt
- (Maybe (Located WarningCategory))
+ (Maybe (Located InWarningCategory))
-- ^ Warning category attached to this WARNING pragma, if any;
-- see Note [Warning categories]
(Located SourceText)
@@ -197,7 +210,7 @@ data WarningTxt pass
-- | To which warning category does this WARNING or DEPRECATED pragma belong?
-- See Note [Warning categories].
warningTxtCategory :: WarningTxt pass -> WarningCategory
-warningTxtCategory (WarningTxt (Just (L _ cat)) _ _) = cat
+warningTxtCategory (WarningTxt (Just (L _ (InWarningCategory _ _ (L _ cat)))) _ _) = cat
warningTxtCategory _ = defaultWarningCategory
-- | The message that the WarningTxt was specified to output
@@ -218,16 +231,22 @@ warningTxtSame w1 w2
| WarningTxt {} <- w1, WarningTxt {} <- w2 = True
| otherwise = False
-deriving instance Eq (IdP pass) => Eq (WarningTxt pass)
+deriving instance Eq InWarningCategory
+
+deriving instance (Eq (HsToken "in"), Eq (IdP pass)) => Eq (WarningTxt pass)
deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass)
+instance Outputable InWarningCategory where
+ ppr (InWarningCategory _ _ wt) = text "in" <+> doubleQuotes (ppr wt)
+
+
instance Outputable (WarningTxt pass) where
ppr (WarningTxt mcat lsrc ws)
= case unLoc lsrc of
NoSourceText -> pp_ws ws
SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}"
where
- ctg_doc = maybe empty (\ctg -> text "in" <+> doubleQuotes (ppr ctg)) mcat
+ ctg_doc = maybe empty (\ctg -> ppr ctg) mcat
ppr (DeprecatedTxt lsrc ds)
=====================================
compiler/Language/Haskell/Syntax/Concrete.hs
=====================================
@@ -35,6 +35,7 @@ data HsToken (tok :: Symbol) = HsTok
-- avoid a dependency.
data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok
+deriving instance Eq (HsToken tok)
deriving instance KnownSymbol tok => Data (HsToken tok)
deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok)
=====================================
libraries/text
=====================================
@@ -1 +1 @@
-Subproject commit fe14df3f578cd49cb72555f25c49843a8671dfd2
+Subproject commit 9fc523cef77f02c465afe00a2f4ac67c388f9945
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -791,7 +791,18 @@ Test22771:
$(CHECK_PPR) $(LIBDIR) Test22771.hs
$(CHECK_EXACT) $(LIBDIR) Test22771.hs
-.PHONY: Test23464
+.PHONY: Test23887
+Test23887:
+ $(CHECK_PPR) $(LIBDIR) Test23887.hs
+ $(CHECK_EXACT) $(LIBDIR) Test23887.hs
+
+.PHONY: Test23465
Test23465:
- $(CHECK_PPR) $(LIBDIR) Test23464.hs
- $(CHECK_EXACT) $(LIBDIR) Test23464.hs
+ $(CHECK_PPR) $(LIBDIR) Test23465.hs
+ $(CHECK_EXACT) $(LIBDIR) Test23465.hs
+
+.PHONY: Test23885
+Test23885:
+ # ppr is not currently unicode aware
+ # $(CHECK_PPR) $(LIBDIR) Test23885.hs
+ $(CHECK_EXACT) $(LIBDIR) Test23885.hs
=====================================
testsuite/tests/printer/Test23464.hs deleted
=====================================
@@ -1,4 +0,0 @@
-module T23465 {-# WaRNING in "x-a" "b" #-} where
-
-{-# WARNInG in "x-c" e "d" #-}
-e = e
=====================================
testsuite/tests/printer/Test23465.hs
=====================================
@@ -0,0 +1,14 @@
+module Test23465 {-# WaRNING in "x-a" "b" #-} where
+
+{-# WARNInG in "x-c" e "d" #-}
+e = e
+
+{-# WARNInG
+ in "x-f" f "fw" ;
+ in "x-f" g "gw"
+#-}
+f = f
+g = g
+
+{-# WARNinG h "hw" #-}
+h = h
=====================================
testsuite/tests/printer/Test23885.hs
=====================================
@@ -0,0 +1,25 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE UnicodeSyntax #-}
+module Test23885 where
+
+import Control.Monad (Monad(..), join, ap)
+import Data.Monoid (Monoid(..))
+import Data.Semigroup (Semigroup(..))
+
+class Monoidy to comp id m | m to → comp id where
+ munit :: id `to` m
+ mjoin :: (m `comp` m) `to` m
+
+newtype Sum a = Sum a deriving Show
+instance Num a ⇒ Monoidy (→) (,) () (Sum a) where
+ munit _ = Sum 0
+ mjoin (Sum x, Sum y) = Sum $ x + y
+
+data NT f g = NT { runNT :: ∀ α. f α → g α }
=====================================
testsuite/tests/printer/Test23887.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE PolyKinds #-}
+module Test23887 where
+-- based on T13343.hs
+import GHC.Exts
+
+type Bad :: forall v . TYPE v
+type Bad @v = (forall (v1 :: RuntimeRep) (a1 :: TYPE v). a1) :: TYPE v
+
+-- Note v /= v1.
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -190,4 +190,5 @@ test('T20531_red_ticks', extra_files(['T20531_defs.hs']), ghci_script, ['T20531_
test('HsDocTy', [ignore_stderr, req_ppr_deps], makefile_test, ['HsDocTy'])
test('Test22765', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22765'])
test('Test22771', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22771'])
-test('Test23464', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23464'])
+test('Test23465', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23465'])
+test('Test23885', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23885'])
=====================================
testsuite/tests/warnings/should_compile/T23465.hs
=====================================
@@ -1,4 +1,4 @@
module T23465 {-# WaRNING in "x-a" "b" #-} where
-{-# WARNInG in "x-c" e "d" #-}
+{-# WARNInG in "x-c-\72" e "d" #-}
e = e
=====================================
testsuite/tests/warnings/should_compile/T23465.stderr
=====================================
@@ -3,7 +3,7 @@
module T23465
{-# WaRNING in "x-a" "b" #-}
where
-{-# WARNInG in "x-c" e "d" #-}
+{-# WARNInG in "x-c-H" e "d" #-}
e = e
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -616,6 +616,15 @@ markEpAnnLMS' (EpAnn anc a cs) l kw (Just str) = do
-- ---------------------------------------------------------------------
+markLToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)
+ => Located (HsToken tok) -> EP w m (Located (HsToken tok))
+markLToken (L (RealSrcSpan aa mb) t) = do
+ epaLoc'<- printStringAtAA (EpaSpan aa mb) (symbolVal (Proxy @tok))
+ case epaLoc' of
+ EpaSpan aa' mb' -> return (L (RealSrcSpan aa' mb') t)
+ _ -> return (L (RealSrcSpan aa mb ) t)
+markLToken (L lt t) = return (L lt t)
+
markToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)
=> LHsToken tok GhcPs -> EP w m (LHsToken tok GhcPs)
markToken (L NoTokenLoc t) = return (L NoTokenLoc t)
@@ -1415,11 +1424,12 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
exact (L (SrcSpanAnn an l) (WarningTxt mb_cat (L la src) ws)) = do
an0 <- markAnnOpenP an src "{-# WARNING"
+ mb_cat' <- markAnnotated mb_cat
an1 <- markEpAnnL an0 lapr_rest AnnOpenS
ws' <- markAnnotated ws
an2 <- markEpAnnL an1 lapr_rest AnnCloseS
an3 <- markAnnCloseP an2
- return (L (SrcSpanAnn an3 l) (WarningTxt mb_cat (L la src) ws'))
+ return (L (SrcSpanAnn an3 l) (WarningTxt mb_cat' (L la src) ws'))
exact (L (SrcSpanAnn an l) (DeprecatedTxt (L ls src) ws)) = do
an0 <- markAnnOpenP an src "{-# DEPRECATED"
@@ -1429,6 +1439,25 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where
an3 <- markAnnCloseP an2
return (L (SrcSpanAnn an3 l) (DeprecatedTxt (L ls src) ws'))
+instance ExactPrint InWarningCategory where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ = a
+
+ exact (InWarningCategory tkIn source (L l wc)) = do
+ tkIn' <- markLToken tkIn
+ L _ (_,wc') <- markAnnotated (L l (source, wc))
+ return (InWarningCategory tkIn' source (L l wc'))
+
+instance ExactPrint (SourceText, WarningCategory) where
+ getAnnotationEntry _ = NoEntryVal
+ setAnnotationAnchor a _ _ = a
+
+ exact (st, WarningCategory wc) = do
+ case st of
+ NoSourceText -> printStringAdvance $ "\"" ++ (unpackFS wc) ++ "\""
+ SourceText src -> printStringAdvance $ (unpackFS src)
+ return (st, WarningCategory wc)
+
-- ---------------------------------------------------------------------
instance ExactPrint (ImportDecl GhcPs) where
@@ -1750,19 +1779,20 @@ instance ExactPrint (WarnDecl GhcPs) where
getAnnotationEntry (Warning an _ _) = fromAnn an
setAnnotationAnchor (Warning an a b) anc cs = Warning (setAnchorEpa an anc cs) a b
- exact (Warning an lns txt) = do
+ exact (Warning an lns (WarningTxt mb_cat src ls )) = do
+ mb_cat' <- markAnnotated mb_cat
lns' <- markAnnotated lns
an0 <- markEpAnnL an lidl AnnOpenS -- "["
- txt' <-
- case txt of
- WarningTxt mb_cat src ls -> do
- ls' <- markAnnotated ls
- return (WarningTxt mb_cat src ls')
- DeprecatedTxt src ls -> do
- ls' <- markAnnotated ls
- return (DeprecatedTxt src ls')
+ ls' <- markAnnotated ls
an1 <- markEpAnnL an0 lidl AnnCloseS -- "]"
- return (Warning an1 lns' txt')
+ return (Warning an1 lns' (WarningTxt mb_cat' src ls'))
+
+ exact (Warning an lns (DeprecatedTxt src ls)) = do
+ lns' <- markAnnotated lns
+ an0 <- markEpAnnL an lidl AnnOpenS -- "["
+ ls' <- markAnnotated ls
+ an1 <- markEpAnnL an0 lidl AnnCloseS -- "]"
+ return (Warning an1 lns' (DeprecatedTxt src ls'))
-- ---------------------------------------------------------------------
@@ -1785,7 +1815,6 @@ instance ExactPrint FastString where
-- exact fs = printStringAdvance (show (unpackFS fs))
exact fs = printStringAdvance (unpackFS fs) >> return fs
-
-- ---------------------------------------------------------------------
instance ExactPrint (RuleDecls GhcPs) where
@@ -3130,7 +3159,6 @@ instance (ExactPrint body)
-- ---------------------------------------------------------------------
--- instance ExactPrint (HsRecUpdField GhcPs q) where
instance (ExactPrint (LocatedA body))
=> ExactPrint (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA body)) where
getAnnotationEntry x = fromAnn (hfbAnn x)
@@ -4087,7 +4115,7 @@ instance ExactPrint (LocatedN RdrName) where
NameAnn a o l c t -> do
mn <- markName a o (Just (l,n)) c
case mn of
- (o', (Just (l',_n)), c') -> do -- (o', (Just (l',n')), c')
+ (o', (Just (l',_n)), c') -> do
t' <- markTrailing t
return (NameAnn a o' l' c' t')
_ -> error "ExactPrint (LocatedN RdrName)"
@@ -4109,10 +4137,23 @@ instance ExactPrint (LocatedN RdrName) where
(o',_,c') <- markName a o Nothing c
t' <- markTrailing t
return (NameAnnOnly a o' c' t')
- NameAnnRArrow nl t -> do
- (AddEpAnn _ nl') <- markKwC NoCaptureComments (AddEpAnn AnnRarrow nl)
+ NameAnnRArrow unicode o nl c t -> do
+ o' <- case o of
+ Just o0 -> do
+ (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn AnnOpenP o0)
+ return (Just o')
+ Nothing -> return Nothing
+ (AddEpAnn _ nl') <-
+ if unicode
+ then markKwC NoCaptureComments (AddEpAnn AnnRarrowU nl)
+ else markKwC NoCaptureComments (AddEpAnn AnnRarrow nl)
+ c' <- case c of
+ Just c0 -> do
+ (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn AnnCloseP c0)
+ return (Just c')
+ Nothing -> return Nothing
t' <- markTrailing t
- return (NameAnnRArrow nl' t')
+ return (NameAnnRArrow unicode o' nl' c' t')
NameAnnQuote q name t -> do
debugM $ "NameAnnQuote"
(AddEpAnn _ q') <- markKwC NoCaptureComments (AddEpAnn AnnSimpleQuote q)
=====================================
utils/check-exact/Main.hs
=====================================
@@ -36,10 +36,11 @@ import GHC.Data.FastString
-- ---------------------------------------------------------------------
_tt :: IO ()
-_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_build/stage1/lib/"
+-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_build/stage1/lib/"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib/"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
+_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/ghc-9.0/_build/stage1/lib"
-- "../../testsuite/tests/ghc-api/exactprint/RenameCase1.hs" (Just changeRenameCase1)
-- "../../testsuite/tests/ghc-api/exactprint/LayoutLet2.hs" (Just changeLayoutLet2)
@@ -205,7 +206,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_b
-- "../../testsuite/tests/printer/Test16279.hs" Nothing
-- "../../testsuite/tests/printer/HsDocTy.hs" Nothing
-- "../../testsuite/tests/printer/Test22765.hs" Nothing
- "../../testsuite/tests/printer/Test22771.hs" Nothing
+ -- "../../testsuite/tests/printer/Test22771.hs" Nothing
+ "../../testsuite/tests/printer/Test23465.hs" Nothing
-- cloneT does not need a test, function can be retired
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 342b0b39bc4a9ac6ddfa616bf7e965263ce78b50
+Subproject commit 4fb6ba7a1fbe5e991b52657ec5b12d018a25b612
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/efb1caeca8d103babba7a06f4a60ae492005f66e...5d5efbd4a6e38b91f1b9dfed9c6a36cedea71b83
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/efb1caeca8d103babba7a06f4a60ae492005f66e...5d5efbd4a6e38b91f1b9dfed9c6a36cedea71b83
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230829/ccc96a47/attachment-0001.html>
More information about the ghc-commits
mailing list