diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs
index af9ef6c9529a6bfc46caa349ddf5e909181bb10b..c036849f911c0a6b32c7ad02e050adbb51b24e0c 100644
--- a/compiler/GHC/Builtin/Names/TH.hs
+++ b/compiler/GHC/Builtin/Names/TH.hs
@@ -82,7 +82,7 @@ templateHaskellNames = [
defaultSigDName, defaultDName,
dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
dataInstDName, newtypeInstDName, tySynInstDName,
- infixLDName, infixRDName, infixNDName,
+ infixLWithSpecDName, infixRWithSpecDName, infixNWithSpecDName,
roleAnnotDName, patSynDName, patSynSigDName,
implicitParamBindDName,
-- Cxt
@@ -143,6 +143,9 @@ templateHaskellNames = [
-- Overlap
overlappableDataConName, overlappingDataConName, overlapsDataConName,
incoherentDataConName,
+ -- NamespaceSpecifier
+ noNamespaceSpecifierDataConName, typeNamespaceSpecifierDataConName,
+ dataNamespaceSpecifierDataConName,
-- DerivStrategy
stockStrategyName, anyclassStrategyName,
newtypeStrategyName, viaStrategyName,
@@ -388,9 +391,9 @@ funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDNa
pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,
standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,
dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
- openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,
- infixNDName, roleAnnotDName, patSynDName, patSynSigDName,
- pragCompleteDName, implicitParamBindDName, pragOpaqueDName :: Name
+ openTypeFamilyDName, closedTypeFamilyDName, infixLWithSpecDName,
+ infixRWithSpecDName, infixNWithSpecDName, roleAnnotDName, patSynDName,
+ patSynSigDName, pragCompleteDName, implicitParamBindDName, pragOpaqueDName :: Name
funDName = libFun (fsLit "funD") funDIdKey
valDName = libFun (fsLit "valD") valDIdKey
dataDName = libFun (fsLit "dataD") dataDIdKey
@@ -421,9 +424,9 @@ tySynInstDName = libFun (fsLit "tySynInstD")
openTypeFamilyDName = libFun (fsLit "openTypeFamilyD") openTypeFamilyDIdKey
closedTypeFamilyDName = libFun (fsLit "closedTypeFamilyD") closedTypeFamilyDIdKey
dataFamilyDName = libFun (fsLit "dataFamilyD") dataFamilyDIdKey
-infixLDName = libFun (fsLit "infixLD") infixLDIdKey
-infixRDName = libFun (fsLit "infixRD") infixRDIdKey
-infixNDName = libFun (fsLit "infixND") infixNDIdKey
+infixLWithSpecDName = libFun (fsLit "infixLWithSpecD") infixLWithSpecDIdKey
+infixRWithSpecDName = libFun (fsLit "infixRWithSpecD") infixRWithSpecDIdKey
+infixNWithSpecDName = libFun (fsLit "infixNWithSpecD") infixNWithSpecDIdKey
roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey
patSynDName = libFun (fsLit "patSynD") patSynDIdKey
patSynSigDName = libFun (fsLit "patSynSigD") patSynSigDIdKey
@@ -665,6 +668,17 @@ overlappingDataConName = thCon (fsLit "Overlapping") overlappingDataConKey
overlapsDataConName = thCon (fsLit "Overlaps") overlapsDataConKey
incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey
+-- data NamespaceSpecifier = ...
+noNamespaceSpecifierDataConName,
+ typeNamespaceSpecifierDataConName,
+ dataNamespaceSpecifierDataConName :: Name
+noNamespaceSpecifierDataConName =
+ thCon (fsLit "NoNamespaceSpecifier") noNamespaceSpecifierDataConKey
+typeNamespaceSpecifierDataConName =
+ thCon (fsLit "TypeNamespaceSpecifier") typeNamespaceSpecifierDataConKey
+dataNamespaceSpecifierDataConName =
+ thCon (fsLit "DataNamespaceSpecifier") dataNamespaceSpecifierDataConKey
+
{- *********************************************************************
* *
Class keys
@@ -773,6 +787,13 @@ overlappingDataConKey = mkPreludeDataConUnique 210
overlapsDataConKey = mkPreludeDataConUnique 211
incoherentDataConKey = mkPreludeDataConUnique 212
+-- data NamespaceSpecifier = ...
+noNamespaceSpecifierDataConKey,
+ typeNamespaceSpecifierDataConKey,
+ dataNamespaceSpecifierDataConKey :: Unique
+noNamespaceSpecifierDataConKey = mkPreludeDataConUnique 213
+typeNamespaceSpecifierDataConKey = mkPreludeDataConUnique 214
+dataNamespaceSpecifierDataConKey = mkPreludeDataConUnique 215
{- *********************************************************************
* *
Id keys
@@ -940,10 +961,10 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey,
openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,
newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
- infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
- patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,
- kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey, typeDataDIdKey,
- pragSCCFunDKey, pragSCCFunNamedDKey :: Unique
+ infixLWithSpecDIdKey, infixRWithSpecDIdKey, infixNWithSpecDIdKey,
+ roleAnnotDIdKey, patSynDIdKey, patSynSigDIdKey, pragCompleteDIdKey,
+ implicitParamBindDIdKey, kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey,
+ typeDataDIdKey, pragSCCFunDKey, pragSCCFunNamedDKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 320
valDIdKey = mkPreludeMiscIdUnique 321
dataDIdKey = mkPreludeMiscIdUnique 322
@@ -966,9 +987,9 @@ dataInstDIdKey = mkPreludeMiscIdUnique 338
newtypeInstDIdKey = mkPreludeMiscIdUnique 339
tySynInstDIdKey = mkPreludeMiscIdUnique 340
closedTypeFamilyDIdKey = mkPreludeMiscIdUnique 341
-infixLDIdKey = mkPreludeMiscIdUnique 342
-infixRDIdKey = mkPreludeMiscIdUnique 343
-infixNDIdKey = mkPreludeMiscIdUnique 344
+infixLWithSpecDIdKey = mkPreludeMiscIdUnique 342
+infixRWithSpecDIdKey = mkPreludeMiscIdUnique 343
+infixNWithSpecDIdKey = mkPreludeMiscIdUnique 344
roleAnnotDIdKey = mkPreludeMiscIdUnique 345
standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346
defaultSigDIdKey = mkPreludeMiscIdUnique 347
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 1a9e4771fb92a237d048ae3164ec21c8ad5913f5..2651d1065ef117f5350925e5ef7decdca562860c 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -54,6 +54,7 @@ import GHC.Types.Name
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Misc ((<||>))
import Data.Function
import Data.List (sortBy)
@@ -719,9 +720,52 @@ type instance XXSig GhcPs = DataConCantHappen
type instance XXSig GhcRn = IdSig
type instance XXSig GhcTc = IdSig
-type instance XFixitySig (GhcPass p) = NoExtField
+type instance XFixitySig GhcPs = NamespaceSpecifier
+type instance XFixitySig GhcRn = NamespaceSpecifier
+type instance XFixitySig GhcTc = NoExtField
type instance XXFixitySig (GhcPass p) = DataConCantHappen
+-- | Optional namespace specifier for fixity signatures,
+-- WARNINIG and DEPRECATED pragmas.
+--
+-- Examples:
+--
+-- {-# WARNING in "x-partial" data Head "don't use this pattern synonym" #-}
+-- -- ↑ DataNamespaceSpecifier
+--
+-- {-# DEPRECATED type D "This type was deprecated" #-}
+-- -- ↑ TypeNamespaceSpecifier
+--
+-- infixr 6 data $
+-- -- ↑ DataNamespaceSpecifier
+data NamespaceSpecifier
+ = NoNamespaceSpecifier
+ | TypeNamespaceSpecifier (EpToken "type")
+ | DataNamespaceSpecifier (EpToken "data")
+ deriving (Eq, Data)
+
+-- | Check if namespace specifiers overlap, i.e. if they are equal or
+-- if at least one of them doesn't specify a namespace
+overlappingNamespaceSpecifiers :: NamespaceSpecifier -> NamespaceSpecifier -> Bool
+overlappingNamespaceSpecifiers NoNamespaceSpecifier _ = True
+overlappingNamespaceSpecifiers _ NoNamespaceSpecifier = True
+overlappingNamespaceSpecifiers TypeNamespaceSpecifier{} TypeNamespaceSpecifier{} = True
+overlappingNamespaceSpecifiers DataNamespaceSpecifier{} DataNamespaceSpecifier{} = True
+overlappingNamespaceSpecifiers _ _ = False
+
+-- | Check if namespace is covered by a namespace specifier:
+-- * NoNamespaceSpecifier covers both namespaces
+-- * TypeNamespaceSpecifier covers the type namespace only
+-- * DataNamespaceSpecifier covers the data namespace only
+coveredByNamespaceSpecifier :: NamespaceSpecifier -> NameSpace -> Bool
+coveredByNamespaceSpecifier NoNamespaceSpecifier = const True
+coveredByNamespaceSpecifier TypeNamespaceSpecifier{} = isTcClsNameSpace <||> isTvNameSpace
+coveredByNamespaceSpecifier DataNamespaceSpecifier{} = isValNameSpace
+instance Outputable NamespaceSpecifier where
+ ppr NoNamespaceSpecifier = empty
+ ppr TypeNamespaceSpecifier{} = text "type"
+ ppr DataNamespaceSpecifier{} = text "data"
+
-- | A type signature in generated code, notably the code
-- generated for record selectors. We simply record the desired Id
-- itself, replete with its name, type and IdDetails. Otherwise it's
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index c5ab6ce654392b1ea2fa6a05ea9daf9d7f698be4..5c12ab709395f4cd43efb0d7c70185d3345226a5 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -81,9 +81,8 @@ module GHC.Hs.Decls (
-- ** Document comments
DocDecl(..), LDocDecl, docDeclDoc,
-- ** Deprecations
- WarnDecl(..), NamespaceSpecifier(..), LWarnDecl,
+ WarnDecl(..), LWarnDecl,
WarnDecls(..), LWarnDecls,
- overlappingNamespaceSpecifiers, coveredByNamespaceSpecifier,
-- ** Annotations
AnnDecl(..), LAnnDecl,
AnnProvenance(..), annProvenanceName_maybe,
@@ -121,7 +120,7 @@ import GHC.Types.Name.Set
import GHC.Types.Fixity
-- others:
-import GHC.Utils.Misc (count, (<||>))
+import GHC.Utils.Misc (count)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.SrcLoc
@@ -1284,27 +1283,6 @@ type instance XXWarnDecls (GhcPass _) = DataConCantHappen
type instance XWarning (GhcPass _) = (NamespaceSpecifier, [AddEpAnn])
type instance XXWarnDecl (GhcPass _) = DataConCantHappen
-data NamespaceSpecifier
- = NoNamespaceSpecifier
- | TypeNamespaceSpecifier (EpToken "type")
- | DataNamespaceSpecifier (EpToken "data")
- deriving (Eq, Data)
-
-overlappingNamespaceSpecifiers :: NamespaceSpecifier -> NamespaceSpecifier -> Bool
-overlappingNamespaceSpecifiers NoNamespaceSpecifier _ = True
-overlappingNamespaceSpecifiers _ NoNamespaceSpecifier = True
-overlappingNamespaceSpecifiers TypeNamespaceSpecifier{} TypeNamespaceSpecifier{} = True
-overlappingNamespaceSpecifiers DataNamespaceSpecifier{} DataNamespaceSpecifier{} = True
-overlappingNamespaceSpecifiers _ _ = False
-
-coveredByNamespaceSpecifier :: NamespaceSpecifier -> NameSpace -> Bool
-coveredByNamespaceSpecifier NoNamespaceSpecifier = const True
-coveredByNamespaceSpecifier TypeNamespaceSpecifier{} = isTcClsNameSpace <||> isTvNameSpace
-coveredByNamespaceSpecifier DataNamespaceSpecifier{} = isValNameSpace
-instance Outputable NamespaceSpecifier where
- ppr NoNamespaceSpecifier = empty
- ppr TypeNamespaceSpecifier{} = text "type"
- ppr DataNamespaceSpecifier{} = text "data"
instance OutputableBndrId p
=> Outputable (WarnDecls (GhcPass p)) where
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 90530e28a3c4fea4cdef7804e707ad7c7d1710b7..ef79d9d4b869812aeb0bfa2b02d0030af52fe788 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -781,15 +781,16 @@ repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
repLFixD (L loc fix_sig) = rep_fix_d (locA loc) fix_sig
rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
-rep_fix_d loc (FixitySig _ names (Fixity _ prec dir))
+rep_fix_d loc (FixitySig ns_spec names (Fixity _ prec dir))
= do { MkC prec' <- coreIntLit prec
; let rep_fn = case dir of
- InfixL -> infixLDName
- InfixR -> infixRDName
- InfixN -> infixNDName
+ InfixL -> infixLWithSpecDName
+ InfixR -> infixRWithSpecDName
+ InfixN -> infixNWithSpecDName
; let do_one name
= do { MkC name' <- lookupLOcc name
- ; dec <- rep2 rep_fn [prec', name']
+ ; MkC ns_spec' <- repNamespaceSpecifier ns_spec
+ ; dec <- rep2 rep_fn [prec', ns_spec', name']
; return (loc,dec) }
; mapM do_one names }
@@ -2677,6 +2678,12 @@ repOverlap mb =
just = coreJust overlapTyConName
+repNamespaceSpecifier :: NamespaceSpecifier -> MetaM (Core (TH.NamespaceSpecifier))
+repNamespaceSpecifier ns_spec = case ns_spec of
+ NoNamespaceSpecifier{} -> dataCon noNamespaceSpecifierDataConName
+ TypeNamespaceSpecifier{} -> dataCon typeNamespaceSpecifierDataConName
+ DataNamespaceSpecifier{} -> dataCon dataNamespaceSpecifierDataConName
+
repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M (TH.TyVarBndr TH.BndrVis))]
-> Core [TH.FunDep] -> Core [(M TH.Dec)]
-> MetaM (Core (M TH.Dec))
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 01eea6721f42832ee57b418300b3a451e0bd9365..9835652f4e7242595737b746a382bd13d97fa6a4 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2616,8 +2616,8 @@ sigdecl :: { LHsDecl GhcPs }
(mkHsWildCardBndrs $5)
; amsA' (sLL $1 $> $ SigD noExtField sig ) }}
- | infix prec ops
- {% do { mbPrecAnn <- traverse (\l2 -> do { checkPrecP l2 $3
+ | infix prec namespace_spec ops
+ {% do { mbPrecAnn <- traverse (\l2 -> do { checkPrecP l2 $4
; pure (mj AnnVal l2) })
$2
; let (fixText, fixPrec) = case $2 of
@@ -2626,7 +2626,7 @@ sigdecl :: { LHsDecl GhcPs }
Nothing -> (NoSourceText, maxPrecedence)
Just l2 -> (fst $ unLoc l2, snd $ unLoc l2)
; amsA' (sLL $1 $> $ SigD noExtField
- (FixSig (mj AnnInfix $1 : maybeToList mbPrecAnn) (FixitySig noExtField (fromOL $ unLoc $3)
+ (FixSig (mj AnnInfix $1 : maybeToList mbPrecAnn) (FixitySig (unLoc $3) (fromOL $ unLoc $4)
(Fixity fixText fixPrec (unLoc $1)))))
}}
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 12edfa5087f681cf9a77a7b9e18b9f33ded89f44..5306b408b5234338b7ff849cd2456031c9dcf1ff 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -23,7 +23,7 @@ module GHC.Rename.Bind (
-- Other bindings
rnMethodBinds, renameSigs,
rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl,
- makeMiniFixityEnv, MiniFixityEnv,
+ makeMiniFixityEnv, MiniFixityEnv, emptyMiniFixityEnv,
HsSigCtxt(..),
-- Utility for hs-boot files
@@ -686,28 +686,47 @@ mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` []
makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv
-makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls
+makeMiniFixityEnv decls = foldlM add_one_sig emptyMiniFixityEnv decls
where
add_one_sig :: MiniFixityEnv -> LFixitySig GhcPs -> RnM MiniFixityEnv
- add_one_sig env (L loc (FixitySig _ names fixity)) =
- foldlM add_one env [ (locA loc,locA name_loc,name,fixity)
+ add_one_sig env (L loc (FixitySig ns_spec names fixity)) =
+ foldlM add_one env [ (locA loc,locA name_loc,name,fixity, ns_spec)
| L name_loc name <- names ]
- add_one env (loc, name_loc, name,fixity) = do
+ add_one env (loc, name_loc, name, fixity, ns_spec) = do
{ -- this fixity decl is a duplicate iff
-- the ReaderName's OccName's FastString is already in the env
-- (we only need to check the local fix_env because
-- definitions of non-local will be caught elsewhere)
let { fs = occNameFS (rdrNameOcc name)
- ; fix_item = L loc fixity };
+ ; fix_item = L loc fixity};
- case lookupFsEnv env fs of
- Nothing -> return $ extendFsEnv env fs fix_item
+ case search_for_dups ns_spec env fs of
+ Nothing -> return $ extend_mini_fixity_env ns_spec env fs fix_item
Just (L loc' _) -> do
{ setSrcSpan loc $
addErrAt name_loc (TcRnMultipleFixityDecls loc' name)
; return env}
}
+ search_for_dups ns_spec MFE{mfe_data_level_names, mfe_type_level_names} fs
+ = case ns_spec of
+ NoNamespaceSpecifier -> case lookupFsEnv mfe_data_level_names fs of
+ -- We only need to find a single duplicate to emit an error about
+ -- multiple fixity decls. Therefore, if we find a duplicate in the
+ -- term-level namespace, then there is no need to look in the type-level namespace.
+ Nothing -> lookupFsEnv mfe_type_level_names fs
+ just_dup -> just_dup
+ TypeNamespaceSpecifier{} -> lookupFsEnv mfe_type_level_names fs
+ DataNamespaceSpecifier{} -> lookupFsEnv mfe_data_level_names fs
+
+ extend_mini_fixity_env ns_spec env@MFE{mfe_data_level_names, mfe_type_level_names} fs fix_item
+ = case ns_spec of
+ NoNamespaceSpecifier -> MFE { mfe_data_level_names = (extendFsEnv mfe_data_level_names fs fix_item)
+ , mfe_type_level_names = (extendFsEnv mfe_type_level_names fs fix_item)}
+
+ TypeNamespaceSpecifier{} -> env { mfe_type_level_names = (extendFsEnv mfe_type_level_names fs fix_item)}
+
+ DataNamespaceSpecifier{} -> env { mfe_data_level_names = (extendFsEnv mfe_data_level_names fs fix_item)}
-- | Multiplicity annotations are a simple wrapper around types. As such,
@@ -1379,16 +1398,19 @@ rnSrcFixityDecl sig_ctxt = rn_decl
-- for con-like things; hence returning a list
-- If neither are in scope, report an error; otherwise
-- return a fixity sig for each (slightly odd)
- rn_decl (FixitySig _ fnames fixity)
- = do names <- concatMapM lookup_one fnames
- return (FixitySig noExtField names fixity)
-
- lookup_one :: LocatedN RdrName -> RnM [LocatedN Name]
- lookup_one (L name_loc rdr_name)
+ rn_decl sig@(FixitySig ns_spec fnames fixity)
+ = do unlessXOptM LangExt.ExplicitNamespaces $
+ when (ns_spec /= NoNamespaceSpecifier) $
+ addErr (TcRnNamespacedFixitySigWithoutFlag sig)
+ names <- concatMapM (lookup_one ns_spec) fnames
+ return (FixitySig ns_spec names fixity)
+
+ lookup_one :: NamespaceSpecifier -> LocatedN RdrName -> RnM [LocatedN Name]
+ lookup_one ns_spec (L name_loc rdr_name)
= setSrcSpanA name_loc $
-- This lookup will fail if the name is not defined in the
-- same binding group as this fixity declaration.
- do names <- lookupLocalTcNames sig_ctxt what NoNamespaceSpecifier rdr_name
+ do names <- lookupLocalTcNames sig_ctxt what ns_spec rdr_name
return [ L name_loc name | (_, name) <- names ]
what = text "fixity signature"
diff --git a/compiler/GHC/Rename/Fixity.hs b/compiler/GHC/Rename/Fixity.hs
index a4da8672afeac0360a89949b2b127fb0f47aa3b8..10300335f3cc4e8c837058d3e4463fa88ac69368 100644
--- a/compiler/GHC/Rename/Fixity.hs
+++ b/compiler/GHC/Rename/Fixity.hs
@@ -4,8 +4,10 @@ fixity environment during renaming.
-}
module GHC.Rename.Fixity
- ( MiniFixityEnv
+ ( MiniFixityEnv(..)
, addLocalFixities
+ , lookupMiniFixityEnv
+ , emptyMiniFixityEnv
, lookupFixityRn
, lookupFixityRn_help
, lookupFieldFixityRn
@@ -63,32 +65,61 @@ deprecation declarations, and lookup of names in GHCi.
-}
--------------------------------
-type MiniFixityEnv = FastStringEnv (Located Fixity)
- -- Mini fixity env for the names we're about
- -- to bind, in a single binding group
- --
- -- It is keyed by the *FastString*, not the *OccName*, because
- -- the single fixity decl infix 3 T
- -- affects both the data constructor T and the type constructor T
- --
- -- We keep the location so that if we find
- -- a duplicate, we can report it sensibly
+
+-- | Mini fixity env for the names we're about
+-- to bind, in a single binding group
+--
+-- It is keyed by the *FastString*, not the *OccName*, because
+-- the single fixity decl @infix 3 T@
+-- affects both the data constructor T and the type constructor T
+--
+-- We keep the location so that if we find
+-- a duplicate, we can report it sensibly
+--
+-- Fixity declarations may influence names in a single namespace by using
+-- a type or data specifier, e.g. in:
+--
+-- > data a :*: b = a :*: b
+-- > infix 3 type :*:
+--
+-- To handle that correctly, MiniFixityEnv contains separate
+-- fields for type-level and data-level names.
+-- If no namespace specifier is provided, the declaration will
+-- populate both the type-level and data-level fields.
+data MiniFixityEnv = MFE
+ { mfe_data_level_names :: FastStringEnv (Located Fixity)
+ , mfe_type_level_names :: FastStringEnv (Located Fixity)
+ }
--------------------------------
-- Used for nested fixity decls to bind names along with their fixities.
-- the fixities are given as a UFM from an OccName's FastString to a fixity decl
addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a
-addLocalFixities mini_fix_env names thing_inside
+addLocalFixities env names thing_inside
= extendFixityEnv (mapMaybe find_fixity names) thing_inside
where
- find_fixity name
- = case lookupFsEnv mini_fix_env (occNameFS occ) of
+ find_fixity name = case lookupMiniFixityEnv env name of
Just lfix -> Just (name, FixItem occ (unLoc lfix))
Nothing -> Nothing
where
occ = nameOccName name
+lookupMiniFixityEnv :: MiniFixityEnv -> Name -> Maybe (Located Fixity)
+lookupMiniFixityEnv MFE{mfe_data_level_names, mfe_type_level_names} name
+ | isValNameSpace namespace = find_fixity_in_env mfe_data_level_names name
+ | otherwise = find_fixity_in_env mfe_type_level_names name
+ where
+ namespace = nameNameSpace name
+
+ find_fixity_in_env mini_fix_env name
+ = lookupFsEnv mini_fix_env (occNameFS occ)
+ where
+ occ = nameOccName name
+
+emptyMiniFixityEnv :: MiniFixityEnv
+emptyMiniFixityEnv = MFE emptyFsEnv emptyFsEnv
+
{-
--------------------------------
lookupFixity is a bit strange.
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 1b123287a1a78747fe071736abaafd741aecf12a..c47e30af4c59d4fea233b41a480a63c71946acfa 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -711,7 +711,7 @@ extendGlobalRdrEnvRn new_gres new_fixities
-- If there is a fixity decl for the gre, add it to the fixity env
extend_fix_env fix_env gre
- | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ)
+ | Just (L _ fi) <- lookupMiniFixityEnv new_fixities name
= extendNameEnv fix_env name (FixItem occ fi)
| otherwise
= fix_env
diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs
index deafb05acf378003ab4e4c97da5ce1b302ab1d21..e431a4f2a686b248bb5484912188ddf9ebba4226 100644
--- a/compiler/GHC/Tc/Deriv.hs
+++ b/compiler/GHC/Tc/Deriv.hs
@@ -294,7 +294,7 @@ renameDeriv inst_infos bagBinds
-- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename
-- auxiliary bindings as if they were defined locally.
-- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
- ; (bndrs, rn_aux_lhs) <- rnLocalValBindsLHS emptyFsEnv aux_val_binds
+ ; (bndrs, rn_aux_lhs) <- rnLocalValBindsLHS emptyMiniFixityEnv aux_val_binds
; bindLocalNames bndrs $
do { (rn_aux, dus_aux) <- rnLocalValBindsRHS (mkNameSet bndrs) rn_aux_lhs
; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index a068e9394c041e0b53859a3898ee7872fa39fbec..1801c1f60b3a40bf535aec937c837067e73b8b4b 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1905,6 +1905,12 @@ instance Diagnostic TcRnMessage where
TcRnInvisPatWithNoForAll tp -> mkSimpleDecorated $
text "Invisible type pattern" <+> ppr tp <+> text "has no associated forall"
+ TcRnNamespacedFixitySigWithoutFlag sig@(FixitySig kw _ _) -> mkSimpleDecorated $
+ vcat [ text "Illegal use of the" <+> quotes (ppr kw) <+> text "keyword:"
+ , nest 2 (ppr sig)
+ , text "in a fixity signature"
+ ]
+
diagnosticReason :: TcRnMessage -> DiagnosticReason
diagnosticReason = \case
TcRnUnknownMessage m
@@ -2535,6 +2541,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnInvisPatWithNoForAll{}
-> ErrorWithoutFlag
+ TcRnNamespacedFixitySigWithoutFlag{}
+ -> ErrorWithoutFlag
diagnosticHints = \case
TcRnUnknownMessage m
@@ -3199,6 +3207,8 @@ instance Diagnostic TcRnMessage where
-> [suggestExtension LangExt.TypeAbstractions]
TcRnInvisPatWithNoForAll{}
-> noHints
+ TcRnNamespacedFixitySigWithoutFlag{}
+ -> [suggestExtension LangExt.ExplicitNamespaces]
diagnosticCode = constructorCode
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index e1a4ff1c3d1efb456966b49481149c6817cc9c15..ec2e4aa3e2a5105793f528ac67cd9930efd51743 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -4209,6 +4209,14 @@ data TcRnMessage where
a namespace specifier is used in {-# WARNING ... #-} or {-# DEPRECATED ... #-}
pragmas without the -XExplicitNamespaces extension enabled
+ Example:
+
+ {-# LANGUAGE NoExplicitNamespaces #-}
+ f = id
+ {-# WARNING data f "some warning message" #-}
+
+ Test cases:
+ T24396c
-}
TcRnNamespacedWarningPragmaWithoutFlag :: WarnDecl GhcPs -> TcRnMessage
@@ -4240,6 +4248,21 @@ data TcRnMessage where
-}
TcRnIllegalInvisibleTypePattern :: HsTyPat GhcPs -> TcRnMessage
+ {-| TcRnNamespacedFixitySigWithoutFlag is an error that occurs when
+ a namespace specifier is used in fixity signatures
+ without the -XExplicitNamespaces extension enabled
+
+ Example:
+
+ {-# LANGUAGE NoExplicitNamespaces #-}
+ f = const
+ infixl 7 data `f`
+
+ Test cases:
+ T14032c
+ -}
+ TcRnNamespacedFixitySigWithoutFlag :: FixitySig GhcPs -> TcRnMessage
+
deriving Generic
----
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 6903e2093d91e8385197b15928e58f43d576dd05..52bcb04a00894d616f2c009a3069f495115a994c 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -243,14 +243,19 @@ cvtDec (TH.KiSigD nm ki)
; let sig' = StandaloneKindSig noAnn nm' ki'
; returnJustLA $ Hs.KindSigD noExtField sig' }
-cvtDec (TH.InfixD fx nm)
+cvtDec (TH.InfixD fx th_ns_spec nm)
-- Fixity signatures are allowed for variables, constructors, and types
-- the renamer automatically looks for types during renaming, even when
-- the RdrName says it's a variable or a constructor. So, just assume
-- it's a variable or constructor and proceed.
= do { nm' <- vcNameN nm
; returnJustLA (Hs.SigD noExtField (FixSig noAnn
- (FixitySig noExtField [nm'] (cvtFixity fx)))) }
+ (FixitySig ns_spec [nm'] (cvtFixity fx)))) }
+ where
+ ns_spec = case th_ns_spec of
+ TH.NoNamespaceSpecifier -> Hs.NoNamespaceSpecifier
+ TH.TypeNamespaceSpecifier -> Hs.TypeNamespaceSpecifier noAnn
+ TH.DataNamespaceSpecifier -> Hs.DataNamespaceSpecifier noAnn
cvtDec (TH.DefaultD tys)
= do { tys' <- traverse cvtType tys
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index d50de9c4057c961beac30fa6e744bf48ee02da48..211affa3cae04a1dc2f3185b3b4e2b88f0189815 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -603,6 +603,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnNamespacedWarningPragmaWithoutFlag" = 14995
GhcDiagnosticCode "TcRnInvisPatWithNoForAll" = 14964
GhcDiagnosticCode "TcRnIllegalInvisibleTypePattern" = 78249
+ GhcDiagnosticCode "TcRnNamespacedFixitySigWithoutFlag" = 78534
-- TcRnTypeApplicationsDisabled
GhcDiagnosticCode "TypeApplication" = 23482
diff --git a/docs/users_guide/9.10.1-notes.rst b/docs/users_guide/9.10.1-notes.rst
index 53cbd7462102b560ff477ee405cf719c68c0253c..2633529325c6b1c7eb729386040452abdd759dd5 100644
--- a/docs/users_guide/9.10.1-notes.rst
+++ b/docs/users_guide/9.10.1-notes.rst
@@ -76,7 +76,13 @@ Language
- GHC Proposal `#65 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0065-type-infix.rst>`_
"Require namespacing fixity declarations for type names and WARNING/DEPRECATED pragmas" has been partially implemented.
Now, with :extension:`ExplicitNamespaces` enabled, you can specify the
- namespace of a name that you want to warn about or deprecate: ::
+ namespace of a name in fixity signatures, ``DEPRECATED`` and ``WARNING`` pragmas: ::
+
+ type f $ a = f a
+ f $ a = f a
+
+ infixl 9 type $ -- type-level $ is left-associative with priority 9
+ infixr 0 data $ -- term-level $ is right-associative with priority 0
{-# DEPRECATED type D "Use `()` instead" #-} -- this will deprecate type D, but will not touch pattern synonym
data D = MkD
@@ -84,7 +90,9 @@ Language
{-# DEPRECATED data D "Use `MkD` instead" #-} -- this will deprecate pattern synonym only
pattern D = MkD
- Ditto for ``{-# WARNING ... #-}`` pragmas.
+ pattern Head x <- (head -> x)
+ {-# WARNING in "x-partial" data Head [ "This is a partial synonym,"
+ , "it throws an error on empty lists."] #-}
Compiler
~~~~~~~~
diff --git a/docs/users_guide/exts/explicit_namespaces.rst b/docs/users_guide/exts/explicit_namespaces.rst
index 04c6ba099c46b5ca572a7710d7532ee46d02d777..74d3a79124af65f84122e37211d2f447fb8bf1c1 100644
--- a/docs/users_guide/exts/explicit_namespaces.rst
+++ b/docs/users_guide/exts/explicit_namespaces.rst
@@ -48,4 +48,36 @@ keyword in patterns and expressions::
f (type t) x = ... -- in a pattern
r = f (type Integer) 10 -- in an expression
-This is used in conjunction with :extension:`RequiredTypeArguments`.
\ No newline at end of file
+This is used in conjunction with :extension:`RequiredTypeArguments`.
+
+When :extension:`ExplicitNamespaces` is enabled, it is possible to use the
+``type`` and ``data`` keywords to specify the namespace of the name used in
+a fixity signature or a ``WARNING``/``DEPRECATED`` pragma. This can be useful for disambiguating
+between names in different namespaces that may conflict with each other.
+
+Here is an example of using namespace specifiers to set different fixities for
+type-level and term-level operators: ::
+
+ type f $ a = f a
+ f $ a = f a
+
+ infixl 9 type $ -- type-level $ is left-associative with priority 9
+ infixr 0 data $ -- term-level $ is right-associative with priority 0
+
+Similarly, it can be used in pragmas to deprecate only one name in a namespace: ::
+
+ data Solo = MkSolo
+
+ pattern Solo = MkSolo
+ {-# DEPRECATED data Solo "Use `MkSolo` instead" #-}
+
+ type family Head xs where
+ Head (x : _) = x
+
+ pattern Head x <- (head -> x)
+
+ {-# WARNING in "x-partial" data Head "this is a partial type synonym" #-}
+
+It is considered bad practice to use a fixity signature, ``WARNING`` pragma, or
+``DEPRECATED`` pragma for a type-level name without an explicit ``type`` namespace, and
+doing so will become an error in a future version of GHC.
diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs
index fd4146b4d470cdee459a48a540f819fdd29dd8d6..9bfa9b608f5ef15e059e4aa1bfc9183e6cccdb34 100644
--- a/libraries/ghci/GHCi/TH/Binary.hs
+++ b/libraries/ghci/GHCi/TH/Binary.hs
@@ -37,6 +37,7 @@ instance Binary TH.Pat
instance Binary TH.ArgPat
instance Binary TH.Exp
instance Binary TH.Dec
+instance Binary TH.NamespaceSpecifier
instance Binary TH.Overlap
instance Binary TH.DerivClause
instance Binary TH.DerivStrategy
diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index 16c8eb561f77eaf30b5a558b427d1d493c897632..7e21c159bac48d4048093c8639e9a10bc309e332 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/Language/Haskell/TH.hs
@@ -80,7 +80,8 @@ module Language.Haskell.TH(
Bang(..), Strict, Foreign(..), Callconv(..), Safety(..), Pragma(..),
Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..),
FunDep(..), TySynEqn(..), TypeFamilyHead(..),
- Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
+ Fixity(..), FixityDirection(..), NamespaceSpecifier(..), defaultFixity,
+ maxPrecedence,
PatSynDir(..), PatSynArgs(..),
-- ** Expressions
Exp(..), Match(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..),
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index ea9875b835d3b3b8ff454c362b2da2ea7f022fd4..b1477ebd9714e37c51d1106fff2e9eab98170267 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -509,13 +509,22 @@ forImpD cc s str n ty
pure $ ForeignD (ImportF cc s str n ty')
infixLD :: Quote m => Int -> Name -> m Dec
-infixLD prec nm = pure (InfixD (Fixity prec InfixL) nm)
+infixLD prec = infixLWithSpecD prec NoNamespaceSpecifier
infixRD :: Quote m => Int -> Name -> m Dec
-infixRD prec nm = pure (InfixD (Fixity prec InfixR) nm)
+infixRD prec = infixRWithSpecD prec NoNamespaceSpecifier
infixND :: Quote m => Int -> Name -> m Dec
-infixND prec nm = pure (InfixD (Fixity prec InfixN) nm)
+infixND prec = infixNWithSpecD prec NoNamespaceSpecifier
+
+infixLWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec
+infixLWithSpecD prec ns_spec nm = pure (InfixD (Fixity prec InfixL) ns_spec nm)
+
+infixRWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec
+infixRWithSpecD prec ns_spec nm = pure (InfixD (Fixity prec InfixR) ns_spec nm)
+
+infixNWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec
+infixNWithSpecD prec ns_spec nm = pure (InfixD (Fixity prec InfixN) ns_spec nm)
defaultD :: Quote m => [m Type] -> m Dec
defaultD tys = DefaultD <$> sequenceA tys
@@ -1092,7 +1101,7 @@ withDecDoc doc dec = do
doc_loc (SigD n _) = Just $ DeclDoc n
doc_loc (ForeignD (ImportF _ _ _ n _)) = Just $ DeclDoc n
doc_loc (ForeignD (ExportF _ _ n _)) = Just $ DeclDoc n
- doc_loc (InfixD _ n) = Just $ DeclDoc n
+ doc_loc (InfixD _ _ n) = Just $ DeclDoc n
doc_loc (DataFamilyD n _ _) = Just $ DeclDoc n
doc_loc (OpenTypeFamilyD (TypeFamilyHead n _ _ _)) = Just $ DeclDoc n
doc_loc (ClosedTypeFamilyD (TypeFamilyHead n _ _ _) _) = Just $ DeclDoc n
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 610728b8ef091d58a29a2f05cf4f33fb9b0352a2..af627ed10fd6256f54e36827cb1eb18054d265f3 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -77,13 +77,19 @@ instance Ppr Info where
ppr_sig :: Name -> Type -> Doc
ppr_sig v ty = pprName' Applied v <+> dcolon <+> ppr ty
-pprFixity :: Name -> Fixity -> Doc
-pprFixity _ f | f == defaultFixity = empty
-pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> pprName' Infix v
+pprFixity :: Name -> Fixity -> NamespaceSpecifier -> Doc
+pprFixity _ f _ | f == defaultFixity = empty
+pprFixity v (Fixity i d) ns_spec
+ = ppr_fix d <+> int i <+> pprNamespaceSpecifier ns_spec <+> pprName' Infix v
where ppr_fix InfixR = text "infixr"
ppr_fix InfixL = text "infixl"
ppr_fix InfixN = text "infix"
+pprNamespaceSpecifier :: NamespaceSpecifier -> Doc
+pprNamespaceSpecifier NoNamespaceSpecifier = empty
+pprNamespaceSpecifier TypeNamespaceSpecifier = text "type"
+pprNamespaceSpecifier DataNamespaceSpecifier = text "data"
+
-- | Pretty prints a pattern synonym type signature
pprPatSynSig :: Name -> PatSynType -> Doc
pprPatSynSig nm ty
@@ -425,7 +431,7 @@ ppr_dec _ (InstanceD o ctxt i ds) =
ppr_dec _ (SigD f t) = pprPrefixOcc f <+> dcolon <+> ppr t
ppr_dec _ (KiSigD f k) = text "type" <+> pprPrefixOcc f <+> dcolon <+> ppr k
ppr_dec _ (ForeignD f) = ppr f
-ppr_dec _ (InfixD fx n) = pprFixity n fx
+ppr_dec _ (InfixD fx ns_spec n) = pprFixity n fx ns_spec
ppr_dec _ (DefaultD tys) =
text "default" <+> parens (sep $ punctuate comma $ map ppr tys)
ppr_dec _ (PragmaD p) = ppr p
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 4baeaf9f1364661c5db702c8c782a8aa501291cb..c937204c69a5aade88140e95f444483207d62695 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -2455,7 +2455,8 @@ data Dec
| ForeignD Foreign -- ^ @{ foreign import ... }
--{ foreign export ... }@
- | InfixD Fixity Name -- ^ @{ infix 3 foo }@
+ | InfixD Fixity NamespaceSpecifier Name
+ -- ^ @{ infix 3 data foo }@
| DefaultD [Type] -- ^ @{ default (Integer, Double) }@
-- | pragmas
@@ -2512,6 +2513,18 @@ data Dec
-- and where clauses which consist entirely of implicit bindings.
deriving( Show, Eq, Ord, Data, Generic )
+-- | A way to specify a namespace to look in when GHC needs to find
+-- a name's source
+data NamespaceSpecifier
+ = NoNamespaceSpecifier -- ^ Name may be everything; If there are two
+ -- names in different namespaces, then consider both
+ | TypeNamespaceSpecifier -- ^ Name should be a type-level entity, such as a
+ -- data type, type alias, type family, type class,
+ -- or type variable
+ | DataNamespaceSpecifier -- ^ Name should be a term-level entity, such as a
+ -- function, data constructor, or pattern synonym
+ deriving( Show, Eq, Ord, Data, Generic )
+
-- | Varieties of allowed instance overlap.
data Overlap = Overlappable -- ^ May be overlapped by more specific instances
| Overlapping -- ^ May overlap a more general instance
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 05bf14b30a1f93cc442a9c72c6a08526a67bab1b..aac4773ab2b5e377e21ac187208fbc740e7fd52e 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -16,6 +16,14 @@
introduced new type alias `ArgPatQ`. Added new function `pprArgPat`. Constructors
`Clause` and `LamE`, now use `ArgPat` instead of `Pat`. New functions `clauseArg` and `lamArgE` were added, both of which accept `[m ArgPat]`. (Ghc Proposal #448).
+ * Add a new data type `NamespaceSpecifier` to represent `type`/`data` namespace specifiers,
+ which can be used in conjunction with the `ExplicitNamespaces` extension:
+
+ * The `InfixD` constructor of the `Dec` data type now stores a `NamespaceSpecifier`.
+
+ * Add `infixLWithSpecD`, `infixRWithSpecD` and `infixNWithSpecD` functions, which
+ accept a `NamespaceSpecifier` as an argument.
+
## 2.21.0.0
* Record fields now belong to separate `NameSpace`s, keyed by the parent of
diff --git a/testsuite/tests/parser/should_compile/T20846.stderr b/testsuite/tests/parser/should_compile/T20846.stderr
index 2fd94dabea593f64ac8806b7b42be1dd9de53be3..535db2237910eab9acbb3e1763a79d241d5f1c4f 100644
--- a/testsuite/tests/parser/should_compile/T20846.stderr
+++ b/testsuite/tests/parser/should_compile/T20846.stderr
@@ -45,7 +45,7 @@
(FixSig
[(AddEpAnn AnnInfix (EpaSpan { T20846.hs:3:1-6 }))]
(FixitySig
- (NoExtField)
+ (NoNamespaceSpecifier)
[(L
(EpAnn
(EpaSpan { T20846.hs:3:8-11 })
diff --git a/testsuite/tests/rename/should_compile/T14032b.hs b/testsuite/tests/rename/should_compile/T14032b.hs
new file mode 100644
index 0000000000000000000000000000000000000000..6051336a87e6db0c02502ed128f7d89df2ab4f84
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T14032b.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE DataKinds, NoStarIsType, ExplicitNamespaces #-}
+
+module Main where
+
+import GHC.TypeLits
+import Prelude hiding ((++), (**))
+import GHC.Types
+
+data Proxy a = P
+
+main = do
+ print (natVal (P @(2 ++ 2 ** 2)))
+ print (2 ++ 2 ** 2)
+ print (2 + 2 * 2)
+
+type a ++ b = a + b
+type a ** b = a * b
+
+a ++ b = a + b
+a ** b = a * b
+
+-- reversed fixity of * and +
+infixl 6 type **
+infixl 7 type ++
+
+-- the same fixity as in * and +
+infixl 7 data **
+infixl 6 data ++
diff --git a/testsuite/tests/rename/should_compile/T14032b.stdout b/testsuite/tests/rename/should_compile/T14032b.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..fea14c26b691d25a3209399c86759b403a79dbff
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T14032b.stdout
@@ -0,0 +1,3 @@
+8
+6
+6
diff --git a/testsuite/tests/rename/should_compile/T14032d.hs b/testsuite/tests/rename/should_compile/T14032d.hs
new file mode 100644
index 0000000000000000000000000000000000000000..313d03f58beff5dd748f5046dbe7aa1609fa5790
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T14032d.hs
@@ -0,0 +1,4 @@
+module T14032d where
+
+infix 5 :*:
+data a :*: b = a :*: b
diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T
index 6f4ddfc628a88456408b8e72779ea21f82404d50..f5d7fe904790b99687366fd49022ae9abf0c6cba 100644
--- a/testsuite/tests/rename/should_compile/all.T
+++ b/testsuite/tests/rename/should_compile/all.T
@@ -221,3 +221,5 @@ test('ExportWarnings5', extra_files(['ExportWarnings_base.hs', 'ExportWarnings_a
test('ExportWarnings6', normal, compile, ['-Wincomplete-export-warnings'])
test('T22478a', req_th, compile, [''])
test('RecordWildCardDeprecation', normal, multimod_compile, ['RecordWildCardDeprecation', '-Wno-duplicate-exports'])
+test('T14032b', normal, compile_and_run, [''])
+test('T14032d', normal, compile, [''])
diff --git a/testsuite/tests/rename/should_fail/T14032c.hs b/testsuite/tests/rename/should_fail/T14032c.hs
new file mode 100644
index 0000000000000000000000000000000000000000..ddd0db98f704c7bc5ed5d29d37eb9c72f4186ac3
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T14032c.hs
@@ -0,0 +1,10 @@
+
+module T14032c where
+
+
+f $ a = f a
+
+type f $ a = f a
+
+infix 0 type $
+infix 0 data $
diff --git a/testsuite/tests/rename/should_fail/T14032c.stderr b/testsuite/tests/rename/should_fail/T14032c.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..bd52709ff9b161622d7693e38d92026654ef0d1a
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T14032c.stderr
@@ -0,0 +1,12 @@
+
+T14032c.hs:1:1: error: [GHC-78534]
+ Illegal use of the ‘type’ keyword:
+ infix 0 $
+ in a fixity signature
+ Suggested fix: Perhaps you intended to use ExplicitNamespaces
+
+T14032c.hs:1:1: error: [GHC-78534]
+ Illegal use of the ‘data’ keyword:
+ infix 0 $
+ in a fixity signature
+ Suggested fix: Perhaps you intended to use ExplicitNamespaces
diff --git a/testsuite/tests/rename/should_fail/T14032f.hs b/testsuite/tests/rename/should_fail/T14032f.hs
new file mode 100644
index 0000000000000000000000000000000000000000..a7c2006544aef28ca59defeffbf846baa0de4043
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T14032f.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE ExplicitNamespaces #-}
+
+module T14032f where
+
+f $ a = f a
+
+type f $$ a = f a
+
+infix 0 type $ -- This should be `data` instead of `type`
+infix 0 data $$ -- This should be `type` instead of `data`
diff --git a/testsuite/tests/rename/should_fail/T14032f.stderr b/testsuite/tests/rename/should_fail/T14032f.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..7c6ee21cf13f7ebeee5130f068c0eb6c27d9a14e
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T14032f.stderr
@@ -0,0 +1,10 @@
+
+T14032f.hs:9:14: error: [GHC-44432]
+ The fixity signature for ‘$’ lacks an accompanying binding
+ Suggested fix:
+ Move the fixity signature to the declaration site of ‘$’.
+
+T14032f.hs:10:14: error: [GHC-44432]
+ The fixity signature for ‘$$’ lacks an accompanying binding
+ Suggested fix:
+ Move the fixity signature to the declaration site of ‘$$’.
diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T
index 038aa8c465fa89dfd38361a8238d79bb32e55bfa..96460bc95e4e0c0b734a146a787ac105a0f212e4 100644
--- a/testsuite/tests/rename/should_fail/all.T
+++ b/testsuite/tests/rename/should_fail/all.T
@@ -225,3 +225,5 @@ test('T23740j', normal, compile_fail, [''])
test('T23570', [extra_files(['T23570_aux.hs'])], multimod_compile_fail, ['T23570', '-v0'])
test('T23570b', [extra_files(['T23570_aux.hs'])], multimod_compile, ['T23570b', '-v0'])
test('T17594b', req_th, compile_fail, [''])
+test('T14032c', normal, compile_fail, [''])
+test('T14032f', normal, compile_fail, [''])
diff --git a/testsuite/tests/th/T11345.hs b/testsuite/tests/th/T11345.hs
index 913671e3e064195d0220dd721db87b2f0e885be0..d1caf97d9a35871c68d7a54cc086e53484c28859 100644
--- a/testsuite/tests/th/T11345.hs
+++ b/testsuite/tests/th/T11345.hs
@@ -25,7 +25,7 @@ $(do gadtName <- newName "GADT2"
, (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int)
] (AppT (ConT gadtName) (ConT ''Int))
] []
- , InfixD (Fixity 7 InfixR) infixName
+ , InfixD (Fixity 7 InfixR) NoNamespaceSpecifier infixName
])
$(return [])
diff --git a/testsuite/tests/th/T14032a.hs b/testsuite/tests/th/T14032a.hs
new file mode 100644
index 0000000000000000000000000000000000000000..66490ad31c24e41962d2e8ad04d0222c399231c5
--- /dev/null
+++ b/testsuite/tests/th/T14032a.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell, ExplicitNamespaces #-}
+module T14032a where
+
+$([d|
+ infix 4 type :*:
+ infix 4 data :*:
+ data a :*: b = a :*: b
+ |])
diff --git a/testsuite/tests/th/T14032e.hs b/testsuite/tests/th/T14032e.hs
new file mode 100644
index 0000000000000000000000000000000000000000..e6d651064b0747ee2667c344940669666517498c
--- /dev/null
+++ b/testsuite/tests/th/T14032e.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T14032e where
+
+$([d| infix 5 :*:
+ data a :*: b = a :*: b
+ |])
diff --git a/testsuite/tests/th/T14032e.stderr b/testsuite/tests/th/T14032e.stderr
new file mode 100644
index 0000000000000000000000000000000000000000..f519da2510aa57c74353e6fd83d96f9c10b76964
--- /dev/null
+++ b/testsuite/tests/th/T14032e.stderr
@@ -0,0 +1,4 @@
+
+T14032e.hs:4:2: error: [GHC-50419]
+ Multiple fixity declarations for ‘:*:’
+ also at T14032e.hs:(4,2)-(6,7)
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 58ef67f9bec3cf18660b98b4c6693b97826a24d5..781e4950dda83fccd7cad9831b3fbae04cacf5a2 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -601,3 +601,5 @@ test('T24111', normal, compile_and_run, [''])
test('T23719', normal, compile_fail, [''])
test('T24190', normal, compile_and_run, [''])
test('T24308', normal, compile_and_run, [''])
+test('T14032a', normal, compile, [''])
+test('T14032e', normal, compile_fail, ['-dsuppress-uniques'])
diff --git a/utils/haddock b/utils/haddock
index 9fcf5cf499102baf9e00986bb8b54b80ec5ffc81..8099c062416e170cb0efd461b2485db1f9d57af5 160000
--- a/utils/haddock
+++ b/utils/haddock
@@ -1 +1 @@
-Subproject commit 9fcf5cf499102baf9e00986bb8b54b80ec5ffc81
+Subproject commit 8099c062416e170cb0efd461b2485db1f9d57af5