[Git][ghc/ghc][wip/sjakobi/T27379] Base subVarSet/subDVarSet on a proper subset operation
by Simon Jakobi (＠sjakobi2) 16 Jun '26
by Simon Jakobi (＠sjakobi2) 16 Jun '26
16 Jun '26
Simon Jakobi pushed to branch wip/sjakobi/T27379 at Glasgow Haskell Compiler / GHC
Commits:
3f0299bd by Simon Jakobi at 2026-06-16T12:42:42+02:00
Base subVarSet/subDVarSet on a proper subset operation
Previously these were defined as isEmpty (s1 minus s2), which
materializes the entire difference map just to test it for emptiness.
The new subUFM/subUDFM use Word64Map.keysAreSubsetOf, which short-circuits
on the first non-member and allocates nothing.
Complexity-wise the recursion is driven by the first map and only probes
the second to depth W (the word width) at each step, never traversing it
in full. So keysAreSubsetOf is O(n*W), i.e. O(n) in the size of the first
map for fixed W, rather than the O(n+m) of the difference-based version.
Closes #27379
Co-Authored-By: Claude Fable 5 <noreply(a)anthropic.com>
- - - - -
5 changed files:
- compiler/GHC/Data/Word64Map/Internal.hs
- compiler/GHC/Data/Word64Map/Lazy.hs
- compiler/GHC/Types/Unique/DFM.hs
- compiler/GHC/Types/Unique/FM.hs
- compiler/GHC/Types/Var/Set.hs
Changes:
=====================================
compiler/GHC/Data/Word64Map/Internal.hs
=====================================
@@ -235,6 +235,7 @@ module GHC.Data.Word64Map.Internal (
-- * Submap
, isSubmapOf, isSubmapOfBy
, isProperSubmapOf, isProperSubmapOfBy
+ , keysAreSubsetOf
-- * Min\/Max
, lookupMin
@@ -2441,6 +2442,21 @@ isSubmapOfBy predicate (Tip k x) t = case lookup k t of
Nothing -> False
isSubmapOfBy _ Nil _ = True
+-- | \(O(n \cdot W)\). Are all of the first map's keys present in the second?
+--
+-- Like @'isSubmapOfBy' (\\_ _ -> True)@ but fully value-agnostic.
+keysAreSubsetOf :: Word64Map a -> Word64Map b -> Bool
+keysAreSubsetOf t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
+ | shorter m1 m2 = False
+ | shorter m2 m1 = match p1 p2 m2 &&
+ if zero p1 m2
+ then keysAreSubsetOf t1 l2
+ else keysAreSubsetOf t1 r2
+ | otherwise = p1 == p2 && keysAreSubsetOf l1 l2 && keysAreSubsetOf r1 r2
+keysAreSubsetOf (Bin _ _ _ _) _ = False
+keysAreSubsetOf (Tip k _) t = member k t
+keysAreSubsetOf Nil _ = True
+
{--------------------------------------------------------------------
Mapping
--------------------------------------------------------------------}
=====================================
compiler/GHC/Data/Word64Map/Lazy.hs
=====================================
@@ -206,6 +206,7 @@ module GHC.Data.Word64Map.Lazy (
-- * Submap
, isSubmapOf, isSubmapOfBy
, isProperSubmapOf, isProperSubmapOfBy
+ , keysAreSubsetOf
-- * Min\/Max
, lookupMin
=====================================
compiler/GHC/Types/Unique/DFM.hs
=====================================
@@ -48,7 +48,7 @@ module GHC.Types.Unique.DFM (
isNullUDFM,
sizeUDFM,
intersectUDFM, udfmIntersectUFM,
- disjointUDFM, disjointUdfmUfm,
+ disjointUDFM, disjointUdfmUfm, subUDFM,
equalKeysUDFM,
minusUDFM,
listToUDFM, listToUDFM_Directly,
@@ -388,6 +388,10 @@ disjointUDFM (UDFM x _i) (UDFM y _j) = M.disjoint x y
disjointUdfmUfm :: UniqDFM key elt -> UniqFM key elt2 -> Bool
disjointUdfmUfm (UDFM x _i) y = M.disjoint x (ufmToIntMap y)
+-- | True if the first map's keys are a subset of the second's.
+subUDFM :: UniqDFM key elt1 -> UniqDFM key elt2 -> Bool
+subUDFM (UDFM x _i) (UDFM y _j) = M.keysAreSubsetOf x y
+
minusUDFM :: UniqDFM key elt1 -> UniqDFM key elt2 -> UniqDFM key elt1
minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i
-- M.difference returns a subset of a left set, so `i` is a good upper
=====================================
compiler/GHC/Types/Unique/FM.hs
=====================================
@@ -66,6 +66,7 @@ module GHC.Types.Unique.FM (
intersectUFM_C,
strictIntersectUFM_C,
disjointUFM,
+ subUFM,
equalKeysUFM,
diffUFM,
nonDetStrictFoldUFM, nonDetFoldUFM, nonDetStrictFoldUFM_DirectlyM,
@@ -430,6 +431,10 @@ strictIntersectUFM_C f (UFM x) (UFM y) = UFM (MS.intersectionWith f x y)
disjointUFM :: UniqFM key elt1 -> UniqFM key elt2 -> Bool
disjointUFM (UFM x) (UFM y) = M.disjoint x y
+-- | True if the first map's keys are a subset of the second's.
+subUFM :: UniqFM key elt1 -> UniqFM key elt2 -> Bool
+subUFM (UFM x) (UFM y) = M.keysAreSubsetOf x y
+
-- | Fold over a 'UniqFM'.
--
-- Non-deterministic, unless the folding function is commutative
=====================================
compiler/GHC/Types/Var/Set.hs
=====================================
@@ -53,8 +53,8 @@ import GHC.Types.Unique
import GHC.Types.Name ( Name )
import GHC.Types.Unique.Set
import GHC.Types.Unique.DSet
-import GHC.Types.Unique.FM( disjointUFM, pluralUFM, pprUFM )
-import GHC.Types.Unique.DFM( disjointUDFM, udfmToUfm, anyUDFM, allUDFM )
+import GHC.Types.Unique.FM( disjointUFM, subUFM, pluralUFM, pprUFM )
+import GHC.Types.Unique.DFM( disjointUDFM, subUDFM, udfmToUfm, anyUDFM, allUDFM )
import GHC.Utils.Outputable (SDoc)
-- | A non-deterministic Variable Set
@@ -141,7 +141,7 @@ mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs
-- See comments with type signatures
intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2)
disjointVarSet s1 s2 = disjointUFM (getUniqSet s1) (getUniqSet s2)
-subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2)
+subVarSet s1 s2 = subUFM (getUniqSet s1) (getUniqSet s2)
anyVarSet :: (Var -> Bool) -> VarSet -> Bool
anyVarSet = uniqSetAny
@@ -261,7 +261,7 @@ dVarSetElems :: DVarSet -> [Var]
dVarSetElems = uniqDSetToList
subDVarSet :: DVarSet -> DVarSet -> Bool
-subDVarSet s1 s2 = isEmptyDVarSet (s1 `minusDVarSet` s2)
+subDVarSet s1 s2 = subUDFM (getUniqDSet s1) (getUniqDSet s2)
unionDVarSet :: DVarSet -> DVarSet -> DVarSet
unionDVarSet = unionUniqDSets
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3f0299bde8063675d36432ff2ebf44a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3f0299bde8063675d36432ff2ebf44a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/mangoiv/26616] compiler: refactor error reporting code for ExplicitLevelImports
by Magnus (＠MangoIV) 16 Jun '26
by Magnus (＠MangoIV) 16 Jun '26
16 Jun '26
Magnus pushed to branch wip/mangoiv/26616 at Glasgow Haskell Compiler / GHC
Commits:
768de01f by mangoiv at 2026-06-16T11:58:01+02:00
compiler: refactor error reporting code for ExplicitLevelImports
Refactors error reporting code for ExplicitLevelImports to pass in a
RdrName and a GlobalReaderElt to be able to report errors that are
faithful to the source and to more precisely distinguish between names
that are in scope from different qualifications.
Fixes #27385 and #26616
- - - - -
30 changed files:
- + changelog.d/26616
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Rename/Splice.hs-boot
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Reader.hs
- testsuite/tests/quotes/LiftErrMsg.stderr
- testsuite/tests/quotes/LiftErrMsgDefer.stderr
- testsuite/tests/quotes/LiftErrMsgTyped.stderr
- testsuite/tests/splice-imports/SI03.stderr
- testsuite/tests/splice-imports/SI05.stderr
- testsuite/tests/splice-imports/SI25.stderr
- testsuite/tests/splice-imports/SI28.stderr
- testsuite/tests/splice-imports/SI31.stderr
- testsuite/tests/splice-imports/T26088.stderr
- testsuite/tests/splice-imports/T26090.stderr
- + testsuite/tests/splice-imports/T26616.hs
- + testsuite/tests/splice-imports/T26616.stderr
- testsuite/tests/splice-imports/all.T
Changes:
=====================================
changelog.d/26616
=====================================
@@ -0,0 +1,9 @@
+section: compiler
+synopsis: Fix bugs with ExplcitLevelImports accepting incorrect qualified imports and reporting errors
+ incorrectly in the presence of qualified imports
+description: When reporting errors, ExplcitLevelImports would sometimes report identifiers qualified at a
+ module they were not oringally actually be qualified at. It would also allow using *any* qualified import
+ to bring an identifier into scope, even if that qualified import was not imported at the correct level.
+ This MR fixes both issues by passing more information to the responsible error reporting code.
+mrs: !16195
+issues: #26616 #27385
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -2254,6 +2254,7 @@ data HsImplicitLiftSplice =
{ implicit_lift_bind_lvl :: S.Set ThLevelIndex
, implicit_lift_used_lvl :: ThLevelIndex
, implicit_lift_gre :: Maybe GlobalRdrElt
+ -- ^ Nothing iff 'LevelCheckReason' is 'LevelCheckInstance'
, implicit_lift_lid :: LIdOccP GhcRn
}
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -12,9 +12,9 @@ module GHC.Rename.Env (
lookupLocatedTopBndrRnN, lookupTopBndrRn,
- lookupLocatedOccRn, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField,
+ lookupLocatedOccRn, lookupLocatedOccRnGRE, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField,
lookupLocatedOccRnNone,
- lookupOccRn, lookupOccRn_maybe, lookupSameOccRn_maybe,
+ lookupOccRn, lookupOccRnGRE, lookupOccRn_maybe, lookupSameOccRn_maybe,
lookupLocalOccRn_maybe, lookupInfoOccRn,
lookupLocalOccThLvl_maybe, lookupLocalOccRn,
lookupTypeOccRn,
@@ -992,6 +992,11 @@ lookupLocatedOccRn :: WhatLooking
-> TcRn (GenLocated (EpAnn ann) Name)
lookupLocatedOccRn what = wrapLocMA (lookupOccRn what)
+lookupLocatedOccRnGRE :: WhatLooking
+ -> GenLocated (EpAnn ann) RdrName
+ -> TcRn (GenLocated (EpAnn ann) GlobalRdrElt)
+lookupLocatedOccRnGRE what = wrapLocMA (lookupOccRnGRE what)
+
lookupLocatedOccRnConstr :: GenLocated (EpAnn ann) RdrName
-> TcRn (GenLocated (EpAnn ann) Name)
lookupLocatedOccRnConstr = wrapLocMA lookupOccRnConstr
@@ -1019,11 +1024,14 @@ lookupLocalOccThLvl_maybe name
-- | lookupOccRn looks up an occurrence of a RdrName, and uses its argument to
-- determine what kind of suggestions should be displayed if it is not in scope
lookupOccRn :: WhatLooking -> RdrName -> RnM Name
-lookupOccRn which_suggest rdr_name
+lookupOccRn which_suggest = fmap greName . lookupOccRnGRE which_suggest
+
+lookupOccRnGRE :: WhatLooking -> RdrName -> RnM GlobalRdrElt
+lookupOccRnGRE which_suggest rdr_name
= do { mb_gre <- lookupOccRn_maybe rdr_name
; case mb_gre of
- Just gre -> return $ greName gre
- Nothing -> reportUnboundName which_suggest rdr_name }
+ Just gre -> return gre
+ Nothing -> mkUnboundGRERdr rdr_name <$ reportUnboundName which_suggest rdr_name }
-- | Look up an occurrence of a 'RdrName'.
--
@@ -1087,16 +1095,22 @@ lookupLocalOccRn rdr_name
-- lookupTypeOccRn looks up an optionally promoted RdrName.
-- Used for looking up type variables.
-lookupTypeOccRn :: RdrName -> RnM Name
+lookupTypeOccRn :: RdrName -> RnM GlobalRdrElt
-- see Note [Demotion]
lookupTypeOccRn rdr_name
= do { mb_gre <- lookupOccRn_maybe rdr_name
; case mb_gre of
- Just gre -> return $ greName gre
- Nothing ->
- if occName rdr_name == occName eqTyCon_RDR -- See Note [eqTyCon (~) compatibility fallback]
- then eqTyConName <$ addDiagnostic TcRnTypeEqualityOutOfScope
- else lookup_demoted rdr_name }
+ Just gre -> return gre
+ Nothing
+ | occName rdr_name == occName eqTyCon_RDR -- See Note [eqTyCon (~) compatibility fallback]
+ -> mkExactGRE
+ eqTyConName
+ -- eqTyCon is not an open family ty con (which is the only
+ -- case in which the functoriality of TyConFlavour actually
+ -- matters)
+ (IAmTyCon (eqTyConName <$ tyConFlavour eqTyCon))
+ <$ addDiagnostic TcRnTypeEqualityOutOfScope
+ | otherwise -> lookup_demoted rdr_name }
{- Note [eqTyCon (~) compatibility fallback]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1113,7 +1127,7 @@ but emit appropriate warnings.
-}
-- Used when looking up a term name (varName or dataName) in a type
-lookup_demoted :: RdrName -> RnM Name
+lookup_demoted :: RdrName -> RnM GlobalRdrElt
lookup_demoted rdr_name
| Just demoted_rdr <- demoteRdrNameTcCls rdr_name
-- Maybe it's the name of a *data* constructor
@@ -1121,11 +1135,12 @@ lookup_demoted rdr_name
; star_is_type <- xoptM LangExt.StarIsType
; let is_star_type = if star_is_type then StarIsType else StarIsNotType
star_is_type_hints = noStarIsTypeHints is_star_type rdr_name
+ mk_unbound_name_GRE hint = unboundGREX looking_for rdr_name hint
; if data_kinds
then do { mb_demoted_gre <- lookupOccRn_maybe demoted_rdr
; case mb_demoted_gre of
- Nothing -> unboundNameX looking_for rdr_name star_is_type_hints
- Just demoted_gre -> return $ greName demoted_gre}
+ Nothing -> mk_unbound_name_GRE star_is_type_hints
+ Just demoted_gre -> return demoted_gre}
else do { -- We need to check if a data constructor of this name is
-- in scope to give good error messages. However, we do
-- not want to give an additional error if the data
@@ -1137,13 +1152,13 @@ lookup_demoted rdr_name
= [SuggestExtension $ SuggestSingleExtension additional LangExt.DataKinds]
| otherwise
= star_is_type_hints
- ; unboundNameX looking_for rdr_name suggestion } }
+ ; mk_unbound_name_GRE suggestion } }
| isQual rdr_name,
Just demoted_rdr_name <- demoteRdrNameTv rdr_name
-- Definitely an illegal term variable, as type variables are never exported.
-- See Note [Demotion of unqualified variables] (W2)
- = report_qualified_term_in_types rdr_name demoted_rdr_name
+ = mkUnboundGREName <$> report_qualified_term_in_types rdr_name demoted_rdr_name
| isUnqual rdr_name,
Just demoted_rdr_name <- demoteRdrNameTv rdr_name
@@ -1152,12 +1167,12 @@ lookup_demoted rdr_name
; if required_type_arguments
then do { mb_demoted_gre <- lookupOccRn_maybe demoted_rdr_name
; case mb_demoted_gre of
- Nothing -> unboundName (LF WL_Anything WL_Anywhere) rdr_name
- Just demoted_gre -> return $ greName demoted_gre }
- else unboundName looking_for rdr_name }
+ Nothing -> unboundGRE (LF WL_Anything WL_Anywhere) rdr_name
+ Just demoted_gre -> return demoted_gre }
+ else unboundGRE looking_for rdr_name }
| otherwise
- = unboundName looking_for rdr_name
+ = unboundGRE looking_for rdr_name
where
looking_for = LF WL_Type WL_Anywhere
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -1,7 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
@@ -321,7 +320,7 @@ rnExpr (HsVar _ (L l v))
-- matching GRE and add a name clash error
-- (see lookupGlobalOccRn_overloaded, called by lookupExprOccRn).
-> do { let sel_name = flSelector $ recFieldLabel fld_info
- ; checkThLocalNameNoLift (L (l2l l) (WithUserRdr v sel_name))
+ ; checkThLocalNameNoLift (L l $ WithUserRdr v gre)
; return (XExpr (HsRecSelRn (FieldOcc v (L l sel_name))), unitFN sel_name)
}
| nm == nilDataConName
@@ -332,7 +331,7 @@ rnExpr (HsVar _ (L l v))
-> rnExpr (ExplicitList noAnn [])
| otherwise
- -> do { res_expr <- checkThLocalNameWithLift (L (l2l l) (WithUserRdr v nm))
+ -> do { res_expr <- checkThLocalNameWithLift (L (l2l l) (WithUserRdr v gre))
; return (res_expr, unitFN nm) }
}}}
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -606,20 +606,21 @@ rnHsTyKi env tv@(HsTyVar _ ip (L loc rdr_name))
TcRnUnexpectedKindVar rdr_name
-- Any type variable at the kind level is illegal without the use
-- of PolyKinds (see #14710)
- ; name <- rnTyVar env rdr_name
+ ; gre <- rnTyVar env rdr_name
; this_mod <- getModule
; explicit_level_imports <- xoptM LangExt.ExplicitLevelImports
- ; let loc_name_with_rdr = L loc $ WithUserRdr rdr_name name
+ ; let loc_gre_with_rdr = L loc $ WithUserRdr rdr_name gre
+ name = greName gre
; if | explicit_level_imports
-- See Note [Strict level checks with ExplicitLevelImports]
- -> checkThLocalNameNoLift loc_name_with_rdr
+ -> checkThLocalNameNoLift loc_gre_with_rdr
| nameIsLocalOrFrom this_mod name
- -> checkThLocalTyName name
+ -> checkThLocalTyName gre
| otherwise -> pure ()
- ; checkPromotedDataConName env tv Prefix ip name
- ; return (HsTyVar noAnn ip loc_name_with_rdr, unitFN name) }
+ ; checkPromotedDataConName env tv Prefix ip $ greName gre
+ ; return (HsTyVar noAnn ip $ fmap greName <$> loc_gre_with_rdr, unitFN name) }
rnHsTyKi env ty@(HsOpTy _ ty1 tyop ty2)
= setSrcSpan (getLocA tyop) $
@@ -826,13 +827,13 @@ throw an error accordingly.
-}
--------------
-rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
+rnTyVar :: RnTyKiEnv -> RdrName -> RnM GlobalRdrElt
rnTyVar env rdr_name
- = do { name <- lookupTypeOccRn rdr_name
- ; checkNamedWildCard env name
- ; return name }
+ = do { gre <- lookupTypeOccRn rdr_name
+ ; checkNamedWildCard env $ greName gre
+ ; return gre }
-rnLTyVar :: LocatedN RdrName -> RnM (LocatedN Name)
+rnLTyVar :: LocatedN RdrName -> RnM (LocatedN GlobalRdrElt)
-- Called externally; does not deal with wildcards
rnLTyVar (L loc rdr_name)
= do { tyvar <- lookupTypeOccRn rdr_name
@@ -843,14 +844,15 @@ rnHsTyOp :: RnTyKiEnv -> HsType GhcPs -> LHsType GhcPs
-> RnM (LHsType GhcRn, FreeNames)
rnHsTyOp env overall_ty tyop
| L l (HsTyVar ann prom (L loc op)) <- tyop
- = do { op' <- rnTyVar env op
+ = do { opgre <- rnTyVar env op
+ ; let opName = greName opgre
; unlessXOptM LangExt.TypeOperators $
- if (op' `hasKey` eqTyConKey) -- See [eqTyCon (~) compatibility fallback] in GHC.Rename.Env
+ if opName `hasKey` eqTyConKey -- See [eqTyCon (~) compatibility fallback] in GHC.Rename.Env
then addDiagnostic TcRnTypeEqualityRequiresOperators
else addErr $ TcRnIllegalTypeOperator (ppr overall_ty) op
- ; checkPromotedDataConName env overall_ty Infix prom op'
- ; let tyop' = L l (HsTyVar ann prom (L loc (WithUserRdr op op')))
- ; return (tyop', unitFN op') }
+ ; checkPromotedDataConName env overall_ty Infix prom opName
+ ; let tyop' = L l (HsTyVar ann prom (L loc (WithUserRdr op opName)))
+ ; return (tyop', unitFN opName) }
| otherwise
= rnLHsTyKi env tyop
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -2491,8 +2491,8 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
bindLocalNames (maybeToList (hsLTyVarName resTv)) $
-- The return type variable scopes over the injectivity annotation
-- e.g. type family F a = (r::*) | r -> a
- do { injFrom' <- rnLTyVar injFrom
- ; injTo' <- mapM rnLTyVar injTo
+ do { injFrom' <- fmap greName <$> rnLTyVar injFrom
+ ; injTo' <- mapM (fmap (fmap greName) . rnLTyVar) injTo
-- Note: srcSpan is unchanged, but typechecker gets
-- confused, l2l call makes it happy
; return $ L (l2l srcSpan) (InjectivityAnn x injFrom' injTo') }
@@ -2533,7 +2533,7 @@ rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn x injFrom injTo)) =
(injDecl', _) <- askNoErrs $ do
injFrom' <- rnLTyVar injFrom
injTo' <- mapM rnLTyVar injTo
- return $ L srcSpan (InjectivityAnn x injFrom' injTo')
+ return $ L srcSpan (InjectivityAnn x (fmap greName injFrom') (fmap (fmap greName) injTo'))
return $ injDecl'
{-
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -1296,7 +1296,8 @@ wrapSrcSpanTPRnM fn (L loc a) = do
lookupTypeOccTPRnM :: RdrName -> TPRnM Name
lookupTypeOccTPRnM rdr_name = liftRnFV $ do
- name <- lookupTypeOccRn rdr_name
+ gre <- lookupTypeOccRn rdr_name
+ let name = greName gre
pure (name, unitFN name)
rn_lty_pat :: LHsType GhcPs -> TPRnM (LHsType GhcRn)
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -1,5 +1,4 @@
{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE MultiWayIf #-}
module GHC.Rename.Splice (
rnTopSpliceDecls,
@@ -40,7 +39,7 @@ import GHC.Unit.Module
import GHC.Types.SrcLoc
import GHC.Rename.HsType ( rnLHsType )
-import Control.Monad ( unless, when )
+import Control.Monad ( unless, when, void )
import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr )
@@ -182,11 +181,12 @@ rnUntypedBracket e br_body
rn_utbracket :: HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeNames)
rn_utbracket (VarBr _ is_value_name rdr_name)
- = do { name <- lookupOccRn (if is_value_name then WL_Term else WL_Type) (unLoc rdr_name)
- ; let res_name = L (l2l (locA rdr_name)) (WithUserRdr (unLoc rdr_name) name)
- ; if is_value_name then checkThLocalNameNoLift res_name else checkThLocalTyName name
- ; check_namespace is_value_name name
- ; return (VarBr noExtField is_value_name (noLocA name), unitFN name) }
+ = do { gre <- lookupOccRnGRE (if is_value_name then WL_Term else WL_Type) (unLoc rdr_name)
+ ; let res_name = L (l2l (locA rdr_name)) (WithUserRdr (unLoc rdr_name) gre)
+ ; let name = greName gre
+ ; if is_value_name then checkThLocalNameNoLift res_name else checkThLocalTyName gre
+ ; check_namespace is_value_name $ greName gre
+ ; return (VarBr noExtField is_value_name (fmap (greName . unwrapUserRdr) res_name), unitFN name) }
rn_utbracket (ExpBr _ e) = do { (e', fvs) <- rnLExpr e
; return (ExpBr noExtField e', fvs) }
@@ -431,10 +431,11 @@ rnUntypedSplice (HsUntypedSpliceExpr _ expr) flavour
rnUntypedSplice (HsQuasiQuote _ quoter quote) flavour
= do { -- Rename the quoter; akin to the HsVar case of rnExpr
- ; quoter' <- lookupLocatedOccRn WL_TermVariable quoter
+ ; quoter' <- lookupLocatedOccRnGRE WL_TermVariable quoter
; let res_name = WithUserRdr (unLoc quoter) <$> quoter'
; checkThLocalNameNoLift res_name
- ; return (HsQuasiQuote (HsQuasiQuoteExt flavour) quoter' quote, unitFN (unLoc quoter')) }
+ ; let loc_name = fmap greName quoter'
+ ; return (HsQuasiQuote (HsQuasiQuoteExt flavour) loc_name quote, unitFN (unLoc loc_name)) }
---------------------
rnTypedSplice :: HsTypedSplice GhcPs -- Typed splice expression
@@ -907,14 +908,14 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src
= vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd
, gen ]
-checkThLocalTyName :: Name -> RnM ()
-checkThLocalTyName name
+checkThLocalTyName :: GlobalRdrElt -> RnM ()
+checkThLocalTyName gre
| isUnboundName name -- Do not report two errors for
= return () -- $(not_in_scope args)
| otherwise
= do { traceRn "checkThLocalTyName" (ppr name)
- ; mb_local_use <- getCurrentAndBindLevel name
+ ; mb_local_use <- getCurrentAndBindLevel gre
; case mb_local_use of {
Nothing -> return () ; -- Not a locally-bound thing
Just (top_lvl, bind_lvl, use_lvl) ->
@@ -932,28 +933,29 @@ checkThLocalTyName name
<+> ppr use_lvl)
; dflags <- getDynFlags
; checkCrossLevelLiftingTy dflags top_lvl bind_lvl use_lvl name } } }
+ where name = greName gre
-- | Check whether we are allowed to use a Name in this context (for TH purposes)
-- In the case of a level incorrect program, attempt to fix it by using
-- a Lift constraint.
-checkThLocalNameWithLift :: LIdOccP GhcRn -> RnM (HsExpr GhcRn)
+checkThLocalNameWithLift :: LocatedN (WithUserRdr GlobalRdrElt) -> RnM (HsExpr GhcRn)
checkThLocalNameWithLift = checkThLocalName True
-- | Check whether we are allowed to use a Name in this context (for TH purposes)
-- In the case of a level incorrect program, do not attempt to fix it by using
-- a Lift constraint.
-checkThLocalNameNoLift :: LIdOccP GhcRn -> RnM ()
-checkThLocalNameNoLift name = checkThLocalName False name >> return ()
+checkThLocalNameNoLift :: LocatedN (WithUserRdr GlobalRdrElt) -> RnM ()
+checkThLocalNameNoLift = void . checkThLocalName False
-- | Implementation of the level checks
-- See Note [Template Haskell levels]
-checkThLocalName :: Bool -> LIdOccP GhcRn -> RnM (HsExpr GhcRn)
-checkThLocalName allow_lifting name_var
+checkThLocalName :: Bool -> LocatedN (WithUserRdr GlobalRdrElt) -> RnM (HsExpr GhcRn)
+checkThLocalName allow_lifting loc_gre
-- Exact and Orig names are not imported, so presumed available at all levels.
-- whenever the user uses exact names, e.g. say @'mkNameG_v' "" "Foo" "bar"@,
-- even though the 'mkNameG_v' here is essentially a quotation, we do not do
-- level checks as we assume that the user was trying to bypass the level checks
- | isExact (userRdrName (unLoc name_var)) || isOrig (userRdrName (unLoc name_var))
+ | isExact rdr || isOrig rdr
= return (HsVar noExtField name_var)
| isUnboundName name -- Do not report two errors for
= return (HsVar noExtField name_var) -- $(not_in_scope args)
@@ -961,7 +963,7 @@ checkThLocalName allow_lifting name_var
= return (HsVar noExtField name_var)
| otherwise
= do {
- mb_local_use <- getCurrentAndBindLevel name
+ mb_local_use <- getCurrentAndBindLevel $ unwrap loc_gre
; case mb_local_use of {
Nothing -> return (HsVar noExtField name_var) ; -- Not a locally-bound thing
Just (top_lvl, bind_lvl, use_lvl) ->
@@ -969,13 +971,12 @@ checkThLocalName allow_lifting name_var
; let is_local
| Just mod <- nameModule_maybe name = mod == cur_mod
| otherwise = True
- ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl <+> ppr use_lvl)
; dflags <- getDynFlags
- ; env <- getGlobalRdrEnv
- ; let mgre = lookupGRE_Name env name
- ; checkCrossLevelLifting dflags (LevelCheckSplice name mgre) top_lvl is_local allow_lifting bind_lvl use_lvl name_var } } }
- where
- name = getName name_var
+ ; checkCrossLevelLifting dflags (LevelCheckSplice $ unLoc loc_gre) top_lvl is_local allow_lifting bind_lvl use_lvl name_var } } }
+ where rdr = userRdrName $ unLoc name_var
+ name_var = fmap greName <$> loc_gre
+ name = unwrap name_var
+ unwrap = unwrapUserRdr . unLoc
--------------------------------------
checkCrossLevelLifting :: DynFlags
@@ -1013,12 +1014,14 @@ checkCrossLevelLifting dflags reason top_lvl_flg is_local allow_lifting bind_lvl
, any (\bind_idx -> use_lvl_idx == incThLevelIndex bind_idx) (Set.toList bind_lvl)
, allow_lifting
= do
- let mgre = case reason of
- LevelCheckSplice _ gre -> gre
- _ -> Nothing
+ let gre
+ | LevelCheckSplice rdr <- reason
+ = Just $! unwrapUserRdr rdr
+ | otherwise
+ = Nothing
(splice_name :: Name) <- newLocalBndrRn (noLocA unqualSplice)
let pend_splice :: HsImplicitLiftSplice
- pend_splice = HsImplicitLiftSplice bind_lvl use_lvl_idx mgre name_var
+ pend_splice = HsImplicitLiftSplice bind_lvl use_lvl_idx gre name_var
-- Warning for implicit lift (#17804)
addDetailedDiagnostic (TcRnImplicitLift name)
=====================================
compiler/GHC/Rename/Splice.hs-boot
=====================================
@@ -2,7 +2,7 @@ module GHC.Rename.Splice where
import GHC.Hs
import GHC.Tc.Utils.Monad
-import GHC.Types.Name (Name)
+import GHC.Types.Name.Reader (WithUserRdr, GlobalRdrElt)
import GHC.Types.Name.Set
@@ -15,6 +15,6 @@ rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeNames)
rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeNames)
-checkThLocalTyName :: Name -> RnM ()
+checkThLocalTyName :: GlobalRdrElt -> RnM ()
-checkThLocalNameNoLift :: LIdOccP GhcRn -> RnM ()
+checkThLocalNameNoLift :: LocatedN (WithUserRdr GlobalRdrElt) -> RnM ()
=====================================
compiler/GHC/Rename/Unbound.hs
=====================================
@@ -11,6 +11,7 @@ module GHC.Rename.Unbound
, mkUnboundNameRdr
, mkUnboundGRE
, mkUnboundGRERdr
+ , mkUnboundGREName
, isUnboundName
, reportUnboundName
, unknownNameSuggestions
@@ -24,6 +25,8 @@ module GHC.Rename.Unbound
, LookingFor(..)
, unboundName
, unboundNameX
+ , unboundGRE
+ , unboundGREX
, unboundTermNameInTypes
, IsTermInTypes(..)
, notInScopeErr
@@ -102,14 +105,23 @@ mkUnboundNameRdr :: RdrName -> Name
mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr)
mkUnboundGRE :: OccName -> GlobalRdrElt
-mkUnboundGRE occ = mkLocalGRE UnboundGRE NoParent $ mkUnboundName occ
+mkUnboundGRE occ = mkUnboundGREName $ mkUnboundName occ
mkUnboundGRERdr :: RdrName -> GlobalRdrElt
-mkUnboundGRERdr rdr = mkLocalGRE UnboundGRE NoParent $ mkUnboundNameRdr rdr
+mkUnboundGRERdr rdr = mkUnboundGREName $ mkUnboundNameRdr rdr
+
+mkUnboundGREName :: Name -> GlobalRdrElt
+mkUnboundGREName = mkLocalGRE UnboundGRE NoParent
reportUnboundName :: WhatLooking -> RdrName -> RnM Name
reportUnboundName what_look rdr = unboundName (LF what_look WL_Anywhere) rdr
+unboundGRE :: LookingFor -> RdrName -> RnM GlobalRdrElt
+unboundGRE lf rdr = mkUnboundGREName <$> unboundName lf rdr
+
+unboundGREX :: LookingFor -> RdrName -> [GhcHint] -> RnM GlobalRdrElt
+unboundGREX lf rdr hints = mkUnboundGREName <$> unboundNameX lf rdr hints
+
unboundName :: LookingFor -> RdrName -> RnM Name
unboundName lf rdr = unboundNameX lf rdr []
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -1188,8 +1188,14 @@ mkImplicitLiftingReporter ctxt
mkImplicitLiftingError :: ErrorItem -> TcRnMessage
mkImplicitLiftingError item =
case errorItemOrigin item of
- ImplicitLiftOrigin (HsImplicitLiftSplice bound used gre name) ->
- TcRnBadlyLevelled (LevelCheckSplice (getName name) gre) bound used (Just item) (cec_defer_type_errors ctxt)
+ -- mgre is Nothing IFF LevelCheckReason is LevelCheckInstance
+ ImplicitLiftOrigin (HsImplicitLiftSplice bound used (Just gre) loc_name) ->
+ TcRnBadlyLevelled
+ (LevelCheckSplice $ gre <$ unLoc loc_name)
+ bound
+ used
+ (Just item)
+ (cec_defer_type_errors ctxt)
_ -> pprPanic "mkImplicitLiftingError" (ppr item)
mkGivenErrorReporter :: Reporter
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -3465,12 +3465,16 @@ pprTcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt = mkDecorated $
(text "No instance for:" <+> quotes (ppr (errorItemPred item)))
| Just item <- [lift_attempt]
] ++
- [ vcat (text "Available from the imports:" : ppr_imports (gre_imp gre))
- | LevelCheckSplice _ (Just gre) <- [reason]
+ [ ppr_imports (gre_imp gre)
+ | LevelCheckSplice (unwrapUserRdr -> gre) <- [reason]
, not (isEmptyBag (gre_imp gre)) ]
where
- ppr_imports :: Bag ImportSpec -> [SDoc]
- ppr_imports = map ((bullet <+>) . ppr ) . bagToList
+ ppr_imports :: Bag ImportSpec -> SDoc
+ ppr_imports bag
+ | [imp] <- impspecs = pprImpSpec imp
+ | otherwise = vcat $ text "Available from the imports:" : map ((bullet <+>) . pprImpSpec) impspecs
+ where impspecs = bagToList bag
+ pprImpSpec imp = ppr imp
note :: SDoc -> SDoc
note note = "Note" <> colon <+> note <> dot
@@ -6250,8 +6254,8 @@ pprLevelCheckReason :: LevelCheckReason -> SDoc
pprLevelCheckReason = \case
LevelCheckInstance _ t ->
text "instance for" <+> quotes (ppr t)
- LevelCheckSplice t _ ->
- quotes (ppr t)
+ LevelCheckSplice t ->
+ quotes $ ppr $ userRdrName t
pprUninferrableTyVarCtx :: UninferrableTyVarCtx -> SDoc
pprUninferrableTyVarCtx = \case
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -6338,7 +6338,7 @@ data WrongThingSort
data LevelCheckReason
= LevelCheckInstance !InstanceWhat !PredType
- | LevelCheckSplice !Name !(Maybe GlobalRdrElt)
+ | LevelCheckSplice !(WithUserRdr GlobalRdrElt)
data UninferrableTyVarCtx
= UninfTyCtx_ClassContext [TcType]
=====================================
compiler/GHC/Tc/Gen/Export.hs
=====================================
@@ -540,7 +540,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
let avail = availFromGRE gre
name = greName gre
- checkThLocalNameNoLift (ieLWrappedUserRdrName l name)
+ checkThLocalNameNoLift $ ieLWrappedUserRdrName l gre
occs' <- check_occs occs ie [gre]
(export_warn_spans', dont_warn_export', warn_txt_rn)
<- process_warning export_warn_spans
@@ -589,7 +589,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
occs' <- check_occs occs ie [gre]
return (Just avail, occs', exp_dflts)
- checkThLocalNameNoLift (ieLWrappedUserRdrName l name)
+ checkThLocalNameNoLift (ieLWrappedUserRdrName l gre)
(export_warn_spans', dont_warn_export', warn_txt_rn)
<- process_warning export_warn_spans
dont_warn_export
@@ -617,7 +617,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
all_gres = par : all_kids
all_names = map greName all_gres
- checkThLocalNameNoLift (ieLWrappedUserRdrName l name)
+ checkThLocalNameNoLift (ieLWrappedUserRdrName l par)
occs' <- check_occs occs ie all_gres
(export_warn_spans', dont_warn_export', warn_txt_rn)
<- process_warning export_warn_spans
@@ -656,7 +656,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
all_gres = par : all_kids
all_names = map greName all_gres
- checkThLocalNameNoLift (ieLWrappedUserRdrName l name)
+ checkThLocalNameNoLift (ieLWrappedUserRdrName l par)
occs' <- check_occs occs ie all_gres
(export_warn_spans', dont_warn_export', warn_txt_rn)
<- process_warning export_warn_spans
@@ -794,8 +794,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
= addUsedGREs ExportDeprecationWarnings (pickGREs parent_rdr kid_gres)
-ieLWrappedUserRdrName :: LIEWrappedName GhcPs -> Name -> LIdOccP GhcRn
-ieLWrappedUserRdrName l n = fmap (\rdr -> WithUserRdr rdr n) $ ieLWrappedName l
+ieLWrappedUserRdrName :: LIEWrappedName GhcPs -> n -> GenLocated SrcSpanAnnN (WithUserRdr n)
+ieLWrappedUserRdrName l n = (\rdr -> WithUserRdr rdr n) <$> ieLWrappedName l
-- | In what namespaces should we go looking for an import/export item
-- that is out of scope, for suggestions in error messages?
@@ -901,7 +901,7 @@ lookupChildrenExport parent_gre child_gres rdr_items = mapAndReportM doOne rdr_i
; return (replaceLWrappedName n ub, gre)}
FoundChild child@(GRE { gre_name = child_nm, gre_par = par }) ->
do { checkPatSynParent spec_parent par child_nm
- ; checkThLocalNameNoLift (ieLWrappedUserRdrName n child_nm)
+ ; checkThLocalNameNoLift (ieLWrappedUserRdrName n child)
; return (replaceLWrappedName n child_nm, child)
}
IncorrectParent p c gs -> failWithDcErr (parentGRE_name p) (greName c) gs
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -135,7 +135,7 @@ import GHC.Types.Unique.Set ( nonDetEltsUniqSet )
import qualified GHC.LanguageExtensions as LangExt
import GHC.Iface.Errors.Types
-import GHC.Rename.Unbound ( unknownNameSuggestions )
+import GHC.Rename.Unbound ( unknownNameSuggestions, mkUnboundGREName )
import GHC.Tc.Errors.Types.PromotionErr
import {-# SOURCE #-} GHC.Tc.Errors.Hole (getHoleFitDispConfig)
@@ -252,15 +252,12 @@ tcLookupGlobal name
env <- getGblEnv
; case lookupNameEnv (tcg_type_env env) name of {
Just thing -> return thing ;
- Nothing ->
-
-- Should it have been in the local envt?
-- (NB: use semantic mod here, since names never use
-- identity module, see Note [Identity versus semantic module].)
- if nameIsLocalOrFrom (tcg_semantic_mod env) name
- then notFound name -- Internal names can happen in GHCi
- else
-
+ Nothing | nameIsLocalOrFrom (tcg_semantic_mod env) name ->
+ notFound $ mkUnboundGREName name -- Internal names can happen in GHCi
+ | otherwise ->
-- Try home package table and external package table
do { mb_thing <- tcLookupImported_maybe name
; case mb_thing of
@@ -1221,10 +1218,10 @@ pprBinders :: [Name] -> SDoc
pprBinders [bndr] = quotes (ppr bndr)
pprBinders bndrs = pprWithCommas ppr bndrs
-notFound :: Name -> TcM TyThing
-notFound name
+notFound :: GlobalRdrElt -> TcM TyThing
+notFound gre
= do { lcl_env <- getLclEnv
- ; lvls <- getCurrentAndBindLevel name
+ ; lvls <- getCurrentAndBindLevel gre
; if -- See Note [Out of scope might be a staging error]
| isUnboundName name -> failM -- If the name really isn't in scope
-- don't report it again (#11941)
@@ -1234,8 +1231,13 @@ notFound name
-- introducing bugs after a refactoring of that
-- function, we check this completely independently
-- before scrutinizing lvls
- | Just (_top_lvl_flag, bind_lvls, lvl@Splice {}) <- lvls
- -> failWithTc (TcRnBadlyLevelled (LevelCheckSplice name Nothing) bind_lvls (thLevelIndex lvl) Nothing ErrorWithoutFlag)
+ | Just (_top_lvl_flag, bind_lvls, lvl@Splice {}) <- lvls -> failWithTc $
+ TcRnBadlyLevelled
+ (LevelCheckSplice (gre <$ noUserRdr name))
+ bind_lvls
+ (thLevelIndex lvl)
+ Nothing
+ ErrorWithoutFlag
| otherwise -> pure ()
; if isTermVarOrFieldNameSpace (nameNameSpace name)
@@ -1260,6 +1262,7 @@ notFound name
-- so let's just not print it! Getting a loop here is
-- very unhelpful, because it hides one compiler bug with another
}
+ where name = greName gre
wrongThingErr :: WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr expected thing name =
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -2468,32 +2468,22 @@ keepAlive name
getThLevel :: TcM ThLevel
getThLevel = do { env <- getLclEnv; return (getLclEnvThLevel env) }
-getCurrentAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, Set.Set ThLevelIndex, ThLevel))
-getCurrentAndBindLevel name
+getCurrentAndBindLevel :: GlobalRdrElt -> TcRn (Maybe (TopLevelFlag, Set.Set ThLevelIndex, ThLevel))
+getCurrentAndBindLevel gre
= do { env <- getLclEnv;
- ; case lookupNameEnv (getLclEnvThBndrs env) name of
- Nothing -> do
- lvls <- getExternalBindLvl name
- if Set.empty == lvls
- -- This case happens when code is generated for identifiers which are not
- -- in scope.
- --
- -- TODO: What happens if someone generates [|| GHC.Magic.dataToTag# ||]
- then do
- return Nothing
- else return (Just (TopLevel, lvls, getLclEnvThLevel env))
- Just (top_lvl, bind_lvl) -> return (Just (top_lvl, Set.singleton bind_lvl, getLclEnvThLevel env)) }
-
-getExternalBindLvl :: Name -> TcRn (Set.Set ThLevelIndex)
-getExternalBindLvl name = do
- env <- getGlobalRdrEnv
- mod <- getModule
- case lookupGRE_Name env name of
- Just gre -> return $ (Set.map thLevelIndexFromImportLevel (greLevels gre))
- Nothing ->
- if nameIsLocalOrFrom mod name
- then return $ Set.singleton topLevelIndex
- else return Set.empty
+ ; return $ case lookupNameEnv (getLclEnvThBndrs env) $ greName gre of
+ Nothing
+ | Set.null lvls -> Nothing
+ -- This case happens when code is generated for identifiers which are not
+ -- in scope.
+ --
+ -- TODO: What happens if someone generates [|| GHC.Magic.dataToTag# ||]
+ | otherwise -> Just (TopLevel, lvls, getLclEnvThLevel env)
+ Just (top_lvl, bind_lvl) -> Just (top_lvl, Set.singleton bind_lvl, getLclEnvThLevel env) }
+ where lvls = getExternalBindLvl gre
+
+getExternalBindLvl :: GlobalRdrElt -> Set.Set ThLevelIndex
+getExternalBindLvl gre = Set.map thLevelIndexFromImportLevel (greLevels gre)
setThLevel :: ThLevel -> TcM a -> TcRn a
setThLevel l = updLclEnv (setLclEnvThLevel l)
=====================================
compiler/GHC/Types/Name/Reader.hs
=====================================
@@ -40,7 +40,7 @@ module GHC.Types.Name.Reader (
isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName,
-- ** Preserving user-written qualification
- WithUserRdr(..), noUserRdr, unLocWithUserRdr, userRdrName,
+ WithUserRdr(..), noUserRdr, unLocWithUserRdr, userRdrName, unwrapUserRdr,
-- * Local mapping of 'RdrName' to 'Name.Name'
LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,
@@ -2247,9 +2247,12 @@ unLocWithUserRdr (L _ (WithUserRdr _ a)) = a
noUserRdr :: Name -> WithUserRdr Name
noUserRdr n = WithUserRdr (nameRdrName n) n
-userRdrName :: WithUserRdr Name -> RdrName
+userRdrName :: WithUserRdr a -> RdrName
userRdrName (WithUserRdr rdr _) = rdr
+unwrapUserRdr :: WithUserRdr a -> a
+unwrapUserRdr (WithUserRdr _ a) = a
+
rdrQual_maybe :: RdrName -> Maybe ModuleName
rdrQual_maybe = \case
Qual q _ -> Just q
=====================================
testsuite/tests/quotes/LiftErrMsg.stderr
=====================================
@@ -2,8 +2,7 @@ LiftErrMsg.hs:14:11: error: [GHC-28914]
• Level error: ‘id’ is bound at level 0 but used at level 1
• Could not be resolved by implicit lifting due to the following error:
No instance for: ‘Lift (a2 -> a2)’
- • Available from the imports:
- • imported from ‘Prelude’
+ • imported from ‘Prelude’
• In the expression: [| id |]
In an equation for ‘test’: test = [| id |]
@@ -11,8 +10,7 @@ LiftErrMsg.hs:17:13: error: [GHC-28914]
• Level error: ‘id’ is bound at level 0 but used at level 1
• Could not be resolved by implicit lifting due to the following error:
No instance for: ‘Lift (a1 -> a1)’
- • Available from the imports:
- • imported from ‘Prelude’
+ • imported from ‘Prelude’
• In the expression: [| (id, id) |]
In an equation for ‘test2’: test2 = [| (id, id) |]
@@ -20,8 +18,7 @@ LiftErrMsg.hs:17:17: error: [GHC-28914]
• Level error: ‘id’ is bound at level 0 but used at level 1
• Could not be resolved by implicit lifting due to the following error:
No instance for: ‘Lift (a0 -> a0)’
- • Available from the imports:
- • imported from ‘Prelude’
+ • imported from ‘Prelude’
• In the expression: [| (id, id) |]
In an equation for ‘test2’: test2 = [| (id, id) |]
=====================================
testsuite/tests/quotes/LiftErrMsgDefer.stderr
=====================================
@@ -4,12 +4,11 @@ LiftErrMsgDefer.hs:14:12: warning: [GHC-28914] [-Wdeferred-type-errors (in -Wdef
• Level error: ‘id’ is bound at level 0 but used at level 1
• Could not be resolved by implicit lifting due to the following error:
No instance for: ‘Lift (a2 -> a2)’
- • Available from the imports:
- • imported from ‘Prelude’
+ • imported from ‘Prelude’
• In the expression: [| id |]
In an equation for ‘test1’: test1 = [| id |]
(deferred type error)
HasCallStack backtrace:
- throw, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:435:30 in ghc-internal:GHC.Internal.Control.Exception.Base
+ throw, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:441:30 in ghc-internal:GHC.Internal.Control.Exception.Base
=====================================
testsuite/tests/quotes/LiftErrMsgTyped.stderr
=====================================
@@ -2,8 +2,7 @@ LiftErrMsgTyped.hs:14:12: error: [GHC-28914]
• Level error: ‘id’ is bound at level 0 but used at level 1
• Could not be resolved by implicit lifting due to the following error:
No instance for: ‘Lift (a -> a)’
- • Available from the imports:
- • imported from ‘Prelude’
+ • imported from ‘Prelude’
• In the typed Template Haskell splice: id
In the Template Haskell typed quotation: [|| id ||]
In the expression: [|| id ||]
@@ -12,8 +11,7 @@ LiftErrMsgTyped.hs:17:14: error: [GHC-28914]
• Level error: ‘id’ is bound at level 0 but used at level 1
• Could not be resolved by implicit lifting due to the following error:
No instance for: ‘Lift (a -> a)’
- • Available from the imports:
- • imported from ‘Prelude’
+ • imported from ‘Prelude’
• In the typed Template Haskell splice: id
In the expression: id
In the Template Haskell typed quotation: [|| (id, id) ||]
=====================================
testsuite/tests/splice-imports/SI03.stderr
=====================================
@@ -1,6 +1,5 @@
SI03.hs:10:11: error: [GHC-28914]
• Level error: ‘sid’ is bound at level 0 but used at level -1
- • Available from the imports:
- • imported from ‘SI01A’ at SI03.hs:5:1-12
+ • imported from ‘SI01A’ at SI03.hs:5:1-12
• In the untyped splice: $(sid [| pure () |])
=====================================
testsuite/tests/splice-imports/SI05.stderr
=====================================
@@ -1,7 +1,6 @@
SI05.hs:10:11: error: [GHC-28914]
- • Level error: ‘SI01A.sid’ is bound at level 0 but used at level -1
- • Available from the imports:
- • imported from ‘SI01A’ at SI05.hs:6:1-12
+ • Level error: ‘sid’ is bound at level 0 but used at level -1
+ • imported from ‘SI01A’ at SI05.hs:6:1-12
• In the untyped splice: $(sid [| pure () |])
SI05.hs:10:11: error: [GHC-87543]
=====================================
testsuite/tests/splice-imports/SI25.stderr
=====================================
@@ -1,8 +1,7 @@
SI25.hs:16:13: error: [GHC-28914]
• Level error: ‘nestedCode’ is bound at level -1
but used at level -2
- • Available from the imports:
- • imported from ‘SI25Helper’ at -1 at SI25.hs:6:1-24
+ • imported from ‘SI25Helper’ at -1 at SI25.hs:6:1-24
• In the untyped splice: $(nestedCode "nested")
In the untyped splice: $($(nestedCode "nested"))
=====================================
testsuite/tests/splice-imports/SI28.stderr
=====================================
@@ -1,7 +1,6 @@
SI28.hs:8:13: error: [GHC-28914]
• Level error: ‘id’ is bound at level 1 but used at level 0
- • Available from the imports:
- • imported from ‘Prelude’ at 1 at SI28.hs:6:1-20
+ • imported from ‘Prelude’ at 1 at SI28.hs:6:1-20
• In the Template Haskell quotation: [| id |]
In the untyped splice: $([| id |])
=====================================
testsuite/tests/splice-imports/SI31.stderr
=====================================
@@ -1,6 +1,5 @@
<interactive>:2:3: error: [GHC-28914]
• Level error: ‘id’ is bound at level 0 but used at level -1
- • Available from the imports:
- • imported from ‘Prelude’
+ • imported from ‘Prelude’
• In the untyped splice: $(id [| () |])
=====================================
testsuite/tests/splice-imports/T26088.stderr
=====================================
@@ -1,6 +1,5 @@
T26088A.hs:8:8: error: [GHC-28914]
• Level error: ‘a’ is bound at level -1 but used at level 1
- • Available from the imports:
- • imported from ‘T26088B’ at -1 at T26088A.hs:4:1-21
+ • imported from ‘T26088B’ at -1 at T26088A.hs:4:1-21
• In the Template Haskell quotation: [| a |]
=====================================
testsuite/tests/splice-imports/T26090.stderr
=====================================
@@ -1,16 +1,13 @@
T26090.hs:2:17: error: [GHC-28914]
• Level error: ‘a’ is bound at level 1 but used at level 0
- • Available from the imports:
- • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20
+ • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20
T26090.hs:4:17: error: [GHC-28914]
• Level error: ‘s’ is bound at level 1 but used at level 0
- • Available from the imports:
- • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20
+ • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20
• In the export: S(s)
T26090.hs:5:17: error: [GHC-28914]
• Level error: ‘R’ is bound at level 1 but used at level 0
- • Available from the imports:
- • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20
+ • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20
=====================================
testsuite/tests/splice-imports/T26616.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE ExplicitLevelImports, NoImplicitPrelude #-}
+module T26616 where
+
+import quote Data.Maybe qualified as Q
+import Data.Maybe qualified as Z
+import splice Data.Maybe qualified as S
+
+foo = Q.isJust
=====================================
testsuite/tests/splice-imports/T26616.stderr
=====================================
@@ -0,0 +1,4 @@
+T26616.hs:8:7: error: [GHC-28914]
+ • Level error: ‘Q.isJust’ is bound at level 1 but used at level 0
+ • imported qualified from ‘Data.Maybe’ at 1 at T26616.hs:4:1-39
+
=====================================
testsuite/tests/splice-imports/all.T
=====================================
@@ -52,3 +52,4 @@ test('T26090', [], multimod_compile_fail, ['T26090', '-v0'])
test('ModuleExport', [], multimod_compile_fail, ['ModuleExport', '-v0'])
test('LevelImportExports', [], makefile_test, [])
test('DodgyLevelExport', [], multimod_compile, ['DodgyLevelExport', '-v0 -Wdodgy-exports'])
+test('T26616', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/768de01f58b7ca6ab85a8fba5567bea…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/768de01f58b7ca6ab85a8fba5567bea…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] EPA: Use standard type family declaration for Anno
by Marge Bot (＠marge-bot) 16 Jun '26
by Marge Bot (＠marge-bot) 16 Jun '26
16 Jun '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
842bef9f by Alan Zimmerman at 2026-06-16T05:48:25-04:00
EPA: Use standard type family declaration for Anno
- - - - -
1 changed file:
- compiler/Language/Haskell/Syntax/Extension.hs
Changes:
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -108,7 +108,7 @@ dataConCantHappen x = case x of {}
-- See Note [XRec and SrcSpans in the AST]
type family XRec p a = r | r -> a
-type family Anno a = b -- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation
+type family Anno a -- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation
{-
Note [XRec and SrcSpans in the AST]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/842bef9f444667c305c186cdc9a48b8…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/842bef9f444667c305c186cdc9a48b8…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] compiler: ignore camelCase and Eta reduce hlint hints
by Marge Bot (＠marge-bot) 16 Jun '26
by Marge Bot (＠marge-bot) 16 Jun '26
16 Jun '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
7f72bcb3 by mangoiv at 2026-06-16T05:47:39-04:00
compiler: ignore camelCase and Eta reduce hlint hints
These do not cohere with the style used in GHC. After disabling them,
hlint lints are much less noisy again.
- - - - -
1 changed file:
- compiler/.hlint.yaml
Changes:
=====================================
compiler/.hlint.yaml
=====================================
@@ -3,6 +3,8 @@
##########################
- ignore: {}
+- ignore: {name: Use camelCase}
+- ignore: {name: Eta reduce}
- warn: {name: Unused LANGUAGE pragma}
- warn: {name: Use fewer LANGUAGE pragmas}
- warn: {name: Redundant return}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f72bcb3389ad97f98276d54cb13bea…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7f72bcb3389ad97f98276d54cb13bea…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Hadrian: fix ghc-internal .def file name
by Marge Bot (＠marge-bot) 16 Jun '26
by Marge Bot (＠marge-bot) 16 Jun '26
16 Jun '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
1314f2fd by David Eichmann at 2026-06-16T05:46:52-04:00
Hadrian: fix ghc-internal .def file name
- - - - -
1 changed file:
- hadrian/src/Rules/Rts.hs
Changes:
=====================================
hadrian/src/Rules/Rts.hs
=====================================
@@ -25,7 +25,7 @@ buildGhcInternalImportDef target = do
buildGhcInternalImportLib :: FilePath -> Action ()
buildGhcInternalImportLib target = do
- let input = dropExtensions target <.> "def" -- the .def file
+ let input = dropExtension (dropExtension target) <.> "def" -- the .def file
output = target -- the .dll.a import lib
need [input]
runBuilder Dlltool ["-d", input, "-l", output] [input] [output]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1314f2fd47056628ccb34fc5878bacb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1314f2fd47056628ccb34fc5878bacb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
893e6133 by Andrew Lelechenko at 2026-06-15T23:55:36+01:00
base: more NonEmpty zips
CLC proposal: https://github.com/haskell/core-libraries-committee/issues/409
- - - - -
6 changed files:
- compiler/GHC/Data/List/NonEmpty.hs
- libraries/base/changelog.md
- libraries/base/src/Data/List/NonEmpty.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
Changes:
=====================================
compiler/GHC/Data/List/NonEmpty.hs
=====================================
@@ -1,10 +1,11 @@
+{-# OPTIONS_GHC -Wno-dodgy-imports #-}
module GHC.Data.List.NonEmpty (module Data.List.NonEmpty, module GHC.Data.List.NonEmpty, toList) where
import Prelude (Bool, (.))
import Control.Applicative
import qualified Control.Monad as List (zipWithM)
import Data.Foldable (Foldable (toList))
-import Data.List.NonEmpty hiding (toList, unzip)
+import Data.List.NonEmpty hiding (toList, unzip, unzip3)
import qualified Data.List as List
import qualified GHC.Data.List as List
=====================================
libraries/base/changelog.md
=====================================
@@ -2,6 +2,7 @@
## 4.24.0.0 *TBA*
* Add `Bounded` instances for `Double`, `Float`, `CDouble` and `CFloat`. ([CLC proposal #402](https://github.com/haskell/core-libraries-committee/issues/402))
+ * Add `Data.List.NonEmpty.{zip{3..7},zipWith{3..7},unzip{3..7}}` ([CLC proposal #409)(https://github.com/haskell/core-libraries-committee/issues/409))
* Ensure that `Data.List.elem` and `notElem` can be specialized even when no list fusion happens. ([CLC proposal #412)(https://github.com/haskell/core-libraries-committee/issues/412))
* Introduce `Data.Double` and `Data.Float` modules. ([CLC proposal #378](https://github.com/haskell/core-libraries-committee/issues/378))
=====================================
libraries/base/src/Data/List/NonEmpty.hs
=====================================
@@ -99,10 +99,29 @@ module Data.List.NonEmpty (
, nubOrdBy -- :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
-- * Indexing streams
, (!!) -- :: NonEmpty a -> Int -> a
+
-- * Zipping and unzipping streams
- , zip -- :: NonEmpty a -> NonEmpty b -> NonEmpty (a,b)
- , zipWith -- :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
- , unzip -- :: Functor f => f (a,b) -> (f a, f b)
+ , zip
+ , zip3
+ , zip4
+ , zip5
+ , zip6
+ , zip7
+
+ , zipWith
+ , zipWith3
+ , zipWith4
+ , zipWith5
+ , zipWith6
+ , zipWith7
+
+ , unzip
+ , unzip3
+ , unzip4
+ , unzip5
+ , unzip6
+ , unzip7
+
-- * Converting to and from a list
, fromList -- :: [a] -> NonEmpty a
, toList -- :: NonEmpty a -> [a]
@@ -116,7 +135,7 @@ import Prelude hiding (break, cycle, drop, dropWhile,
last, length, map, repeat, reverse,
scanl, scanl1, scanr, scanr1, span,
splitAt, tail, take, takeWhile,
- unzip, zip, zipWith, (!!), Applicative(..))
+ unzip, unzip3, zip, zip3, zipWith, zipWith3, (!!), Applicative(..))
import qualified Prelude
import Control.Applicative (Applicative (..), Alternative (many))
@@ -560,12 +579,97 @@ isPrefixOf (y:ys) (x :| xs) = (y == x) && List.isPrefixOf ys xs
| otherwise = error "NonEmpty.!! negative index"
infixl 9 !!
+-- | The 'zip3' function takes three streams and returns a stream of
+-- corresponding triples.
+zip3 :: NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty (a, b, c)
+zip3 (x :| xs) (y :| ys) (z :| zs) = (x, y, z) :| List.zip3 xs ys zs
+
+-- | The 'zip4' function takes four streams and returns a stream of
+-- corresponding quadruples.
+zip4 :: NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty (a, b, c, d)
+zip4 (x :| xs) (y :| ys) (z :| zs) (t :| ts) = (x, y, z, t) :| List.zip4 xs ys zs ts
+
+-- | The 'zip5' function takes five streams and returns a stream of
+-- corresponding quintuples.
+zip5 :: NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty (a, b, c, d, e)
+zip5 (x :| xs) (y :| ys) (z :| zs) (t :| ts) (u :| us) = (x, y, z, t, u) :| List.zip5 xs ys zs ts us
+
+-- | The 'zip6' function takes six streams and returns a stream of
+-- corresponding sextuples.
+zip6 :: NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty (a, b, c, d, e, f)
+zip6 (x :| xs) (y :| ys) (z :| zs) (t :| ts) (u :| us) (v :| vs) = (x, y, z, t, u, v) :| List.zip6 xs ys zs ts us vs
+
+-- | The 'zip7' function takes seven streams and returns a stream of
+-- corresponding septuples.
+zip7 :: NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g -> NonEmpty (a, b, c, d, e, f, g)
+zip7 (x :| xs) (y :| ys) (z :| zs) (t :| ts) (u :| us) (v :| vs) (w :| ws) = (x, y, z, t, u, v, w) :| List.zip7 xs ys zs ts us vs ws
+
+-- | The 'zipWith3' function generalizes 'zip3'. Rather than tupling
+-- the elements, the elements are combined using the function
+-- passed as the first argument.
+zipWith3 :: (a -> b -> c -> d) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d
+zipWith3 f (x :| xs) (y :| ys) (z :| zs) = f x y z :| List.zipWith3 f xs ys zs
+
+-- | The 'zipWith4' function generalizes 'zip4'. Rather than tupling
+-- the elements, the elements are combined using the function
+-- passed as the first argument.
+zipWith4 :: (a -> b -> c -> d -> e) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e
+zipWith4 f (x :| xs) (y :| ys) (z :| zs) (t :| ts) = f x y z t :| List.zipWith4 f xs ys zs ts
+
+-- | The 'zipWith5' function generalizes 'zip5'. Rather than tupling
+-- the elements, the elements are combined using the function
+-- passed as the first argument.
+zipWith5 :: (a -> b -> c -> d -> e -> f) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f
+zipWith5 f (x :| xs) (y :| ys) (z :| zs) (t :| ts) (u :| us) = f x y z t u :| List.zipWith5 f xs ys zs ts us
+
+-- | The 'zipWith6' function generalizes 'zip6'. Rather than tupling
+-- the elements, the elements are combined using the function
+-- passed as the first argument.
+zipWith6 :: (a -> b -> c -> d -> e -> f -> g) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g
+zipWith6 f (x :| xs) (y :| ys) (z :| zs) (t :| ts) (u :| us) (v :| vs) = f x y z t u v :| List.zipWith6 f xs ys zs ts us vs
+
+-- | The 'zipWith7' function generalizes 'zip7'. Rather than tupling
+-- the elements, the elements are combined using the function
+-- passed as the first argument.
+zipWith7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g -> NonEmpty h
+zipWith7 f (x :| xs) (y :| ys) (z :| zs) (t :| ts) (u :| us) (v :| vs) (w :| ws) = f x y z t u v w :| List.zipWith7 f xs ys zs ts us vs ws
+
-- | The 'unzip' function is the inverse of the 'zip' function.
unzip :: NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)
unzip ((a, b) :| asbs) = (a :| as, b :| bs)
where
(as, bs) = List.unzip asbs
+-- | The 'unzip3' function is the inverse of the 'zip3' function.
+unzip3 :: NonEmpty (a, b, c) -> (NonEmpty a, NonEmpty b, NonEmpty c)
+unzip3 ((a, b, c) :| asbscs) = (a :| as, b :| bs, c :| cs)
+ where
+ (as, bs, cs) = List.unzip3 asbscs
+
+-- | The 'unzip4' function is the inverse of the 'zip4' function.
+unzip4 :: NonEmpty (a, b, c, d) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d)
+unzip4 ((a, b, c, d) :| asbscsds) = (a :| as, b :| bs, c :| cs, d :| ds)
+ where
+ (as, bs, cs, ds) = List.unzip4 asbscsds
+
+-- | The 'unzip5' function is the inverse of the 'zip5' function.
+unzip5 :: NonEmpty (a, b, c, d, e) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e)
+unzip5 ((a, b, c, d, e) :| asbscsdses) = (a :| as, b :| bs, c :| cs, d :| ds, e :| es)
+ where
+ (as, bs, cs, ds, es) = List.unzip5 asbscsdses
+
+-- | The 'unzip6' function is the inverse of the 'zip6' function.
+unzip6 :: NonEmpty (a, b, c, d, e, f) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e, NonEmpty f)
+unzip6 ((a, b, c, d, e, f) :| asbscsdsesfs) = (a :| as, b :| bs, c :| cs, d :| ds, e :| es, f :| fs)
+ where
+ (as, bs, cs, ds, es, fs) = List.unzip6 asbscsdsesfs
+
+-- | The 'unzip7' function is the inverse of the 'zip7' function.
+unzip7 :: NonEmpty (a, b, c, d, e, f, g) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e, NonEmpty f, NonEmpty g)
+unzip7 ((a, b, c, d, e, f, g) :| asbscsdsesfsgs) = (a :| as, b :| bs, c :| cs, d :| ds, e :| es, f :| fs, g :| gs)
+ where
+ (as, bs, cs, ds, es, fs, gs) = List.unzip7 asbscsdsesfsgs
+
-- | The 'nub' function removes duplicate elements from a list. In
-- particular, it keeps only the first occurrence of each element.
-- (The name 'nub' means \'essence\'.)
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -1521,9 +1521,24 @@ module Data.List.NonEmpty where
unfold :: forall a b. (a -> (b, GHC.Internal.Maybe.Maybe a)) -> a -> NonEmpty b
unfoldr :: forall a b. (a -> (b, GHC.Internal.Maybe.Maybe a)) -> a -> NonEmpty b
unzip :: forall a b. NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)
+ unzip3 :: forall a b c. NonEmpty (a, b, c) -> (NonEmpty a, NonEmpty b, NonEmpty c)
+ unzip4 :: forall a b c d. NonEmpty (a, b, c, d) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d)
+ unzip5 :: forall a b c d e. NonEmpty (a, b, c, d, e) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e)
+ unzip6 :: forall a b c d e f. NonEmpty (a, b, c, d, e, f) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e, NonEmpty f)
+ unzip7 :: forall a b c d e f g. NonEmpty (a, b, c, d, e, f, g) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e, NonEmpty f, NonEmpty g)
xor :: NonEmpty GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool
zip :: forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
+ zip3 :: forall a b c. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty (a, b, c)
+ zip4 :: forall a b c d. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty (a, b, c, d)
+ zip5 :: forall a b c d e. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty (a, b, c, d, e)
+ zip6 :: forall a b c d e f. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty (a, b, c, d, e, f)
+ zip7 :: forall a b c d e f g. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g -> NonEmpty (a, b, c, d, e, f, g)
zipWith :: forall a b c. (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
+ zipWith3 :: forall a b c d. (a -> b -> c -> d) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d
+ zipWith4 :: forall a b c d e. (a -> b -> c -> d -> e) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e
+ zipWith5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f
+ zipWith6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g
+ zipWith7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g -> NonEmpty h
module Data.Maybe where
-- Safety: Safe
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -1521,9 +1521,24 @@ module Data.List.NonEmpty where
unfold :: forall a b. (a -> (b, GHC.Internal.Maybe.Maybe a)) -> a -> NonEmpty b
unfoldr :: forall a b. (a -> (b, GHC.Internal.Maybe.Maybe a)) -> a -> NonEmpty b
unzip :: forall a b. NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)
+ unzip3 :: forall a b c. NonEmpty (a, b, c) -> (NonEmpty a, NonEmpty b, NonEmpty c)
+ unzip4 :: forall a b c d. NonEmpty (a, b, c, d) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d)
+ unzip5 :: forall a b c d e. NonEmpty (a, b, c, d, e) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e)
+ unzip6 :: forall a b c d e f. NonEmpty (a, b, c, d, e, f) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e, NonEmpty f)
+ unzip7 :: forall a b c d e f g. NonEmpty (a, b, c, d, e, f, g) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e, NonEmpty f, NonEmpty g)
xor :: NonEmpty GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool
zip :: forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
+ zip3 :: forall a b c. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty (a, b, c)
+ zip4 :: forall a b c d. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty (a, b, c, d)
+ zip5 :: forall a b c d e. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty (a, b, c, d, e)
+ zip6 :: forall a b c d e f. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty (a, b, c, d, e, f)
+ zip7 :: forall a b c d e f g. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g -> NonEmpty (a, b, c, d, e, f, g)
zipWith :: forall a b c. (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
+ zipWith3 :: forall a b c d. (a -> b -> c -> d) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d
+ zipWith4 :: forall a b c d e. (a -> b -> c -> d -> e) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e
+ zipWith5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f
+ zipWith6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g
+ zipWith7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g -> NonEmpty h
module Data.Maybe where
-- Safety: Safe
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -1521,9 +1521,24 @@ module Data.List.NonEmpty where
unfold :: forall a b. (a -> (b, GHC.Internal.Maybe.Maybe a)) -> a -> NonEmpty b
unfoldr :: forall a b. (a -> (b, GHC.Internal.Maybe.Maybe a)) -> a -> NonEmpty b
unzip :: forall a b. NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)
+ unzip3 :: forall a b c. NonEmpty (a, b, c) -> (NonEmpty a, NonEmpty b, NonEmpty c)
+ unzip4 :: forall a b c d. NonEmpty (a, b, c, d) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d)
+ unzip5 :: forall a b c d e. NonEmpty (a, b, c, d, e) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e)
+ unzip6 :: forall a b c d e f. NonEmpty (a, b, c, d, e, f) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e, NonEmpty f)
+ unzip7 :: forall a b c d e f g. NonEmpty (a, b, c, d, e, f, g) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e, NonEmpty f, NonEmpty g)
xor :: NonEmpty GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool
zip :: forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
+ zip3 :: forall a b c. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty (a, b, c)
+ zip4 :: forall a b c d. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty (a, b, c, d)
+ zip5 :: forall a b c d e. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty (a, b, c, d, e)
+ zip6 :: forall a b c d e f. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty (a, b, c, d, e, f)
+ zip7 :: forall a b c d e f g. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g -> NonEmpty (a, b, c, d, e, f, g)
zipWith :: forall a b c. (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
+ zipWith3 :: forall a b c d. (a -> b -> c -> d) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d
+ zipWith4 :: forall a b c d e. (a -> b -> c -> d -> e) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e
+ zipWith5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f
+ zipWith6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g
+ zipWith7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g -> NonEmpty h
module Data.Maybe where
-- Safety: Safe
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/893e6133eb2684dce77c8670bbfa587…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/893e6133eb2684dce77c8670bbfa587…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/mangoiv/26616] compiler: refactor error reporting code for ExplicitLevelImports
by Magnus (＠MangoIV) 16 Jun '26
by Magnus (＠MangoIV) 16 Jun '26
16 Jun '26
Magnus pushed to branch wip/mangoiv/26616 at Glasgow Haskell Compiler / GHC
Commits:
462ffb0b by mangoiv at 2026-06-16T11:45:42+02:00
compiler: refactor error reporting code for ExplicitLevelImports
Refactors error reporting code for ExplicitLevelImports to pass in a
RdrName and a GlobalReaderElt to be able to report errors that are
faithful to the source and to more precisely distinguish between names
that are in scope from different qualifications.
Fixes #27385 and #26616
- - - - -
30 changed files:
- + changelog.d/26616
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Rename/Splice.hs-boot
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Reader.hs
- testsuite/tests/quotes/LiftErrMsg.stderr
- testsuite/tests/quotes/LiftErrMsgDefer.stderr
- testsuite/tests/quotes/LiftErrMsgTyped.stderr
- testsuite/tests/splice-imports/SI03.stderr
- testsuite/tests/splice-imports/SI05.stderr
- testsuite/tests/splice-imports/SI25.stderr
- testsuite/tests/splice-imports/SI28.stderr
- testsuite/tests/splice-imports/SI31.stderr
- testsuite/tests/splice-imports/T26088.stderr
- testsuite/tests/splice-imports/T26090.stderr
- + testsuite/tests/splice-imports/T26616.hs
- + testsuite/tests/splice-imports/T26616.stderr
- testsuite/tests/splice-imports/all.T
Changes:
=====================================
changelog.d/26616
=====================================
@@ -0,0 +1,9 @@
+section: compiler
+synopsis: Fix bugs with ExplcitLevelImports accepting incorrect qualified imports and reporting errors
+ incorrectly in the presence of qualified imports
+description: When reporting errors, ExplcitLevelImports would sometimes report identifiers qualified at a
+ module they were not oringally actually be qualified at. It would also allow using *any* qualified import
+ to bring an identifier into scope, even if that qualified import was not imported at the correct level.
+ This MR fixes both issues by passing more information to the responsible error reporting code.
+mrs: !16195
+issues: #26616 #27385
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -2254,6 +2254,7 @@ data HsImplicitLiftSplice =
{ implicit_lift_bind_lvl :: S.Set ThLevelIndex
, implicit_lift_used_lvl :: ThLevelIndex
, implicit_lift_gre :: Maybe GlobalRdrElt
+ -- ^ Nothing iff 'LevelCheckReason' is 'LevelCheckInstance'
, implicit_lift_lid :: LIdOccP GhcRn
}
=====================================
compiler/GHC/Rename/Env.hs
=====================================
@@ -12,9 +12,9 @@ module GHC.Rename.Env (
lookupLocatedTopBndrRnN, lookupTopBndrRn,
- lookupLocatedOccRn, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField,
+ lookupLocatedOccRn, lookupLocatedOccRnGre, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField,
lookupLocatedOccRnNone,
- lookupOccRn, lookupOccRn_maybe, lookupSameOccRn_maybe,
+ lookupOccRn, lookupOccRnGre, lookupOccRn_maybe, lookupSameOccRn_maybe,
lookupLocalOccRn_maybe, lookupInfoOccRn,
lookupLocalOccThLvl_maybe, lookupLocalOccRn,
lookupTypeOccRn,
@@ -992,6 +992,11 @@ lookupLocatedOccRn :: WhatLooking
-> TcRn (GenLocated (EpAnn ann) Name)
lookupLocatedOccRn what = wrapLocMA (lookupOccRn what)
+lookupLocatedOccRnGre :: WhatLooking
+ -> GenLocated (EpAnn ann) RdrName
+ -> TcRn (GenLocated (EpAnn ann) GlobalRdrElt)
+lookupLocatedOccRnGre what = wrapLocMA (lookupOccRnGre what)
+
lookupLocatedOccRnConstr :: GenLocated (EpAnn ann) RdrName
-> TcRn (GenLocated (EpAnn ann) Name)
lookupLocatedOccRnConstr = wrapLocMA lookupOccRnConstr
@@ -1019,11 +1024,14 @@ lookupLocalOccThLvl_maybe name
-- | lookupOccRn looks up an occurrence of a RdrName, and uses its argument to
-- determine what kind of suggestions should be displayed if it is not in scope
lookupOccRn :: WhatLooking -> RdrName -> RnM Name
-lookupOccRn which_suggest rdr_name
+lookupOccRn which_suggest = fmap greName . lookupOccRnGre which_suggest
+
+lookupOccRnGre :: WhatLooking -> RdrName -> RnM GlobalRdrElt
+lookupOccRnGre which_suggest rdr_name
= do { mb_gre <- lookupOccRn_maybe rdr_name
; case mb_gre of
- Just gre -> return $ greName gre
- Nothing -> reportUnboundName which_suggest rdr_name }
+ Just gre -> return gre
+ Nothing -> mkUnboundGRERdr rdr_name <$ reportUnboundName which_suggest rdr_name }
-- | Look up an occurrence of a 'RdrName'.
--
@@ -1087,16 +1095,22 @@ lookupLocalOccRn rdr_name
-- lookupTypeOccRn looks up an optionally promoted RdrName.
-- Used for looking up type variables.
-lookupTypeOccRn :: RdrName -> RnM Name
+lookupTypeOccRn :: RdrName -> RnM GlobalRdrElt
-- see Note [Demotion]
lookupTypeOccRn rdr_name
= do { mb_gre <- lookupOccRn_maybe rdr_name
; case mb_gre of
- Just gre -> return $ greName gre
- Nothing ->
- if occName rdr_name == occName eqTyCon_RDR -- See Note [eqTyCon (~) compatibility fallback]
- then eqTyConName <$ addDiagnostic TcRnTypeEqualityOutOfScope
- else lookup_demoted rdr_name }
+ Just gre -> return gre
+ Nothing
+ | occName rdr_name == occName eqTyCon_RDR -- See Note [eqTyCon (~) compatibility fallback]
+ -> mkExactGRE
+ eqTyConName
+ -- eqTyCon is not an open family ty con (which is the only
+ -- case in which the functoriality of TyConFlavour actually
+ -- matters)
+ (IAmTyCon (eqTyConName <$ tyConFlavour eqTyCon))
+ <$ addDiagnostic TcRnTypeEqualityOutOfScope
+ | otherwise -> lookup_demoted rdr_name }
{- Note [eqTyCon (~) compatibility fallback]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1113,7 +1127,7 @@ but emit appropriate warnings.
-}
-- Used when looking up a term name (varName or dataName) in a type
-lookup_demoted :: RdrName -> RnM Name
+lookup_demoted :: RdrName -> RnM GlobalRdrElt
lookup_demoted rdr_name
| Just demoted_rdr <- demoteRdrNameTcCls rdr_name
-- Maybe it's the name of a *data* constructor
@@ -1121,11 +1135,12 @@ lookup_demoted rdr_name
; star_is_type <- xoptM LangExt.StarIsType
; let is_star_type = if star_is_type then StarIsType else StarIsNotType
star_is_type_hints = noStarIsTypeHints is_star_type rdr_name
+ mk_unbound_name_GRE hint = unboundGREX looking_for rdr_name hint
; if data_kinds
then do { mb_demoted_gre <- lookupOccRn_maybe demoted_rdr
; case mb_demoted_gre of
- Nothing -> unboundNameX looking_for rdr_name star_is_type_hints
- Just demoted_gre -> return $ greName demoted_gre}
+ Nothing -> mk_unbound_name_GRE star_is_type_hints
+ Just demoted_gre -> return demoted_gre}
else do { -- We need to check if a data constructor of this name is
-- in scope to give good error messages. However, we do
-- not want to give an additional error if the data
@@ -1137,13 +1152,13 @@ lookup_demoted rdr_name
= [SuggestExtension $ SuggestSingleExtension additional LangExt.DataKinds]
| otherwise
= star_is_type_hints
- ; unboundNameX looking_for rdr_name suggestion } }
+ ; mk_unbound_name_GRE suggestion } }
| isQual rdr_name,
Just demoted_rdr_name <- demoteRdrNameTv rdr_name
-- Definitely an illegal term variable, as type variables are never exported.
-- See Note [Demotion of unqualified variables] (W2)
- = report_qualified_term_in_types rdr_name demoted_rdr_name
+ = mkLocalGRE UnboundGRE NoParent <$> report_qualified_term_in_types rdr_name demoted_rdr_name
| isUnqual rdr_name,
Just demoted_rdr_name <- demoteRdrNameTv rdr_name
@@ -1152,12 +1167,12 @@ lookup_demoted rdr_name
; if required_type_arguments
then do { mb_demoted_gre <- lookupOccRn_maybe demoted_rdr_name
; case mb_demoted_gre of
- Nothing -> unboundName (LF WL_Anything WL_Anywhere) rdr_name
- Just demoted_gre -> return $ greName demoted_gre }
- else unboundName looking_for rdr_name }
+ Nothing -> unboundGRE (LF WL_Anything WL_Anywhere) rdr_name
+ Just demoted_gre -> return demoted_gre }
+ else unboundGRE looking_for rdr_name }
| otherwise
- = unboundName looking_for rdr_name
+ = unboundGRE looking_for rdr_name
where
looking_for = LF WL_Type WL_Anywhere
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -1,7 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
@@ -321,7 +320,7 @@ rnExpr (HsVar _ (L l v))
-- matching GRE and add a name clash error
-- (see lookupGlobalOccRn_overloaded, called by lookupExprOccRn).
-> do { let sel_name = flSelector $ recFieldLabel fld_info
- ; checkThLocalNameNoLift (L (l2l l) (WithUserRdr v sel_name))
+ ; checkThLocalNameNoLift (L l $ WithUserRdr v gre)
; return (XExpr (HsRecSelRn (FieldOcc v (L l sel_name))), unitFN sel_name)
}
| nm == nilDataConName
@@ -332,7 +331,7 @@ rnExpr (HsVar _ (L l v))
-> rnExpr (ExplicitList noAnn [])
| otherwise
- -> do { res_expr <- checkThLocalNameWithLift (L (l2l l) (WithUserRdr v nm))
+ -> do { res_expr <- checkThLocalNameWithLift (L (l2l l) (WithUserRdr v gre))
; return (res_expr, unitFN nm) }
}}}
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -606,20 +606,21 @@ rnHsTyKi env tv@(HsTyVar _ ip (L loc rdr_name))
TcRnUnexpectedKindVar rdr_name
-- Any type variable at the kind level is illegal without the use
-- of PolyKinds (see #14710)
- ; name <- rnTyVar env rdr_name
+ ; gre <- rnTyVar env rdr_name
; this_mod <- getModule
; explicit_level_imports <- xoptM LangExt.ExplicitLevelImports
- ; let loc_name_with_rdr = L loc $ WithUserRdr rdr_name name
+ ; let loc_mgre_with_rdr = L loc $ WithUserRdr rdr_name gre
+ name = greName gre
; if | explicit_level_imports
-- See Note [Strict level checks with ExplicitLevelImports]
- -> checkThLocalNameNoLift loc_name_with_rdr
+ -> checkThLocalNameNoLift loc_mgre_with_rdr
| nameIsLocalOrFrom this_mod name
- -> checkThLocalTyName name
+ -> checkThLocalTyName gre
| otherwise -> pure ()
- ; checkPromotedDataConName env tv Prefix ip name
- ; return (HsTyVar noAnn ip loc_name_with_rdr, unitFN name) }
+ ; checkPromotedDataConName env tv Prefix ip $ greName gre
+ ; return (HsTyVar noAnn ip $ fmap greName <$> loc_mgre_with_rdr, unitFN name) }
rnHsTyKi env ty@(HsOpTy _ ty1 tyop ty2)
= setSrcSpan (getLocA tyop) $
@@ -826,13 +827,13 @@ throw an error accordingly.
-}
--------------
-rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
+rnTyVar :: RnTyKiEnv -> RdrName -> RnM GlobalRdrElt
rnTyVar env rdr_name
- = do { name <- lookupTypeOccRn rdr_name
- ; checkNamedWildCard env name
- ; return name }
+ = do { mgre <- lookupTypeOccRn rdr_name
+ ; checkNamedWildCard env $ greName mgre
+ ; return mgre }
-rnLTyVar :: LocatedN RdrName -> RnM (LocatedN Name)
+rnLTyVar :: LocatedN RdrName -> RnM (LocatedN GlobalRdrElt)
-- Called externally; does not deal with wildcards
rnLTyVar (L loc rdr_name)
= do { tyvar <- lookupTypeOccRn rdr_name
@@ -843,14 +844,15 @@ rnHsTyOp :: RnTyKiEnv -> HsType GhcPs -> LHsType GhcPs
-> RnM (LHsType GhcRn, FreeNames)
rnHsTyOp env overall_ty tyop
| L l (HsTyVar ann prom (L loc op)) <- tyop
- = do { op' <- rnTyVar env op
+ = do { opmgre <- rnTyVar env op
+ ; let opName = greName opmgre
; unlessXOptM LangExt.TypeOperators $
- if (op' `hasKey` eqTyConKey) -- See [eqTyCon (~) compatibility fallback] in GHC.Rename.Env
+ if opName `hasKey` eqTyConKey -- See [eqTyCon (~) compatibility fallback] in GHC.Rename.Env
then addDiagnostic TcRnTypeEqualityRequiresOperators
else addErr $ TcRnIllegalTypeOperator (ppr overall_ty) op
- ; checkPromotedDataConName env overall_ty Infix prom op'
- ; let tyop' = L l (HsTyVar ann prom (L loc (WithUserRdr op op')))
- ; return (tyop', unitFN op') }
+ ; checkPromotedDataConName env overall_ty Infix prom opName
+ ; let tyop' = L l (HsTyVar ann prom (L loc (WithUserRdr op opName)))
+ ; return (tyop', unitFN opName) }
| otherwise
= rnLHsTyKi env tyop
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -2491,8 +2491,8 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
bindLocalNames (maybeToList (hsLTyVarName resTv)) $
-- The return type variable scopes over the injectivity annotation
-- e.g. type family F a = (r::*) | r -> a
- do { injFrom' <- rnLTyVar injFrom
- ; injTo' <- mapM rnLTyVar injTo
+ do { injFrom' <- fmap greName <$> rnLTyVar injFrom
+ ; injTo' <- mapM (fmap (fmap greName) . rnLTyVar) injTo
-- Note: srcSpan is unchanged, but typechecker gets
-- confused, l2l call makes it happy
; return $ L (l2l srcSpan) (InjectivityAnn x injFrom' injTo') }
@@ -2533,7 +2533,7 @@ rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn x injFrom injTo)) =
(injDecl', _) <- askNoErrs $ do
injFrom' <- rnLTyVar injFrom
injTo' <- mapM rnLTyVar injTo
- return $ L srcSpan (InjectivityAnn x injFrom' injTo')
+ return $ L srcSpan (InjectivityAnn x (fmap greName injFrom') (fmap (fmap greName) injTo'))
return $ injDecl'
{-
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -1296,7 +1296,8 @@ wrapSrcSpanTPRnM fn (L loc a) = do
lookupTypeOccTPRnM :: RdrName -> TPRnM Name
lookupTypeOccTPRnM rdr_name = liftRnFV $ do
- name <- lookupTypeOccRn rdr_name
+ gre <- lookupTypeOccRn rdr_name
+ let name = greName gre
pure (name, unitFN name)
rn_lty_pat :: LHsType GhcPs -> TPRnM (LHsType GhcRn)
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -1,5 +1,4 @@
{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE MultiWayIf #-}
module GHC.Rename.Splice (
rnTopSpliceDecls,
@@ -40,7 +39,7 @@ import GHC.Unit.Module
import GHC.Types.SrcLoc
import GHC.Rename.HsType ( rnLHsType )
-import Control.Monad ( unless, when )
+import Control.Monad ( unless, when, void )
import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr )
@@ -182,11 +181,12 @@ rnUntypedBracket e br_body
rn_utbracket :: HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeNames)
rn_utbracket (VarBr _ is_value_name rdr_name)
- = do { name <- lookupOccRn (if is_value_name then WL_Term else WL_Type) (unLoc rdr_name)
- ; let res_name = L (l2l (locA rdr_name)) (WithUserRdr (unLoc rdr_name) name)
- ; if is_value_name then checkThLocalNameNoLift res_name else checkThLocalTyName name
- ; check_namespace is_value_name name
- ; return (VarBr noExtField is_value_name (noLocA name), unitFN name) }
+ = do { gre <- lookupOccRnGre (if is_value_name then WL_Term else WL_Type) (unLoc rdr_name)
+ ; let res_name = L (l2l (locA rdr_name)) (WithUserRdr (unLoc rdr_name) gre)
+ ; let name = greName gre
+ ; if is_value_name then checkThLocalNameNoLift res_name else checkThLocalTyName gre
+ ; check_namespace is_value_name $ greName gre
+ ; return (VarBr noExtField is_value_name (fmap (greName . unwrapUserRdr) res_name), unitFN name) }
rn_utbracket (ExpBr _ e) = do { (e', fvs) <- rnLExpr e
; return (ExpBr noExtField e', fvs) }
@@ -431,10 +431,11 @@ rnUntypedSplice (HsUntypedSpliceExpr _ expr) flavour
rnUntypedSplice (HsQuasiQuote _ quoter quote) flavour
= do { -- Rename the quoter; akin to the HsVar case of rnExpr
- ; quoter' <- lookupLocatedOccRn WL_TermVariable quoter
+ ; quoter' <- lookupLocatedOccRnGre WL_TermVariable quoter
; let res_name = WithUserRdr (unLoc quoter) <$> quoter'
; checkThLocalNameNoLift res_name
- ; return (HsQuasiQuote (HsQuasiQuoteExt flavour) quoter' quote, unitFN (unLoc quoter')) }
+ ; let loc_name = fmap greName quoter'
+ ; return (HsQuasiQuote (HsQuasiQuoteExt flavour) loc_name quote, unitFN (unLoc loc_name)) }
---------------------
rnTypedSplice :: HsTypedSplice GhcPs -- Typed splice expression
@@ -907,14 +908,14 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src
= vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd
, gen ]
-checkThLocalTyName :: Name -> RnM ()
-checkThLocalTyName name
+checkThLocalTyName :: GlobalRdrElt -> RnM ()
+checkThLocalTyName gre
| isUnboundName name -- Do not report two errors for
= return () -- $(not_in_scope args)
| otherwise
= do { traceRn "checkThLocalTyName" (ppr name)
- ; mb_local_use <- getCurrentAndBindLevel name
+ ; mb_local_use <- getCurrentAndBindLevel gre
; case mb_local_use of {
Nothing -> return () ; -- Not a locally-bound thing
Just (top_lvl, bind_lvl, use_lvl) ->
@@ -932,28 +933,29 @@ checkThLocalTyName name
<+> ppr use_lvl)
; dflags <- getDynFlags
; checkCrossLevelLiftingTy dflags top_lvl bind_lvl use_lvl name } } }
+ where name = greName gre
-- | Check whether we are allowed to use a Name in this context (for TH purposes)
-- In the case of a level incorrect program, attempt to fix it by using
-- a Lift constraint.
-checkThLocalNameWithLift :: LIdOccP GhcRn -> RnM (HsExpr GhcRn)
+checkThLocalNameWithLift :: LocatedN (WithUserRdr GlobalRdrElt) -> RnM (HsExpr GhcRn)
checkThLocalNameWithLift = checkThLocalName True
-- | Check whether we are allowed to use a Name in this context (for TH purposes)
-- In the case of a level incorrect program, do not attempt to fix it by using
-- a Lift constraint.
-checkThLocalNameNoLift :: LIdOccP GhcRn -> RnM ()
-checkThLocalNameNoLift name = checkThLocalName False name >> return ()
+checkThLocalNameNoLift :: LocatedN (WithUserRdr GlobalRdrElt) -> RnM ()
+checkThLocalNameNoLift = void . checkThLocalName False
-- | Implementation of the level checks
-- See Note [Template Haskell levels]
-checkThLocalName :: Bool -> LIdOccP GhcRn -> RnM (HsExpr GhcRn)
-checkThLocalName allow_lifting name_var
+checkThLocalName :: Bool -> LocatedN (WithUserRdr GlobalRdrElt) -> RnM (HsExpr GhcRn)
+checkThLocalName allow_lifting loc_gre
-- Exact and Orig names are not imported, so presumed available at all levels.
-- whenever the user uses exact names, e.g. say @'mkNameG_v' "" "Foo" "bar"@,
-- even though the 'mkNameG_v' here is essentially a quotation, we do not do
-- level checks as we assume that the user was trying to bypass the level checks
- | isExact (userRdrName (unLoc name_var)) || isOrig (userRdrName (unLoc name_var))
+ | isExact rdr || isOrig rdr
= return (HsVar noExtField name_var)
| isUnboundName name -- Do not report two errors for
= return (HsVar noExtField name_var) -- $(not_in_scope args)
@@ -961,7 +963,7 @@ checkThLocalName allow_lifting name_var
= return (HsVar noExtField name_var)
| otherwise
= do {
- mb_local_use <- getCurrentAndBindLevel name
+ mb_local_use <- getCurrentAndBindLevel $ unwrap loc_gre
; case mb_local_use of {
Nothing -> return (HsVar noExtField name_var) ; -- Not a locally-bound thing
Just (top_lvl, bind_lvl, use_lvl) ->
@@ -969,13 +971,12 @@ checkThLocalName allow_lifting name_var
; let is_local
| Just mod <- nameModule_maybe name = mod == cur_mod
| otherwise = True
- ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl <+> ppr use_lvl)
; dflags <- getDynFlags
- ; env <- getGlobalRdrEnv
- ; let mgre = lookupGRE_Name env name
- ; checkCrossLevelLifting dflags (LevelCheckSplice name mgre) top_lvl is_local allow_lifting bind_lvl use_lvl name_var } } }
- where
- name = getName name_var
+ ; checkCrossLevelLifting dflags (LevelCheckSplice $ unLoc loc_gre) top_lvl is_local allow_lifting bind_lvl use_lvl name_var } } }
+ where rdr = userRdrName $ unLoc name_var
+ name_var = fmap greName <$> loc_gre
+ name = unwrap name_var
+ unwrap = unwrapUserRdr . unLoc
--------------------------------------
checkCrossLevelLifting :: DynFlags
@@ -1013,9 +1014,11 @@ checkCrossLevelLifting dflags reason top_lvl_flg is_local allow_lifting bind_lvl
, any (\bind_idx -> use_lvl_idx == incThLevelIndex bind_idx) (Set.toList bind_lvl)
, allow_lifting
= do
- let mgre = case reason of
- LevelCheckSplice _ gre -> gre
- _ -> Nothing
+ let mgre
+ | LevelCheckSplice rdr <- reason
+ = Just $! unwrapUserRdr rdr
+ | otherwise
+ = Nothing
(splice_name :: Name) <- newLocalBndrRn (noLocA unqualSplice)
let pend_splice :: HsImplicitLiftSplice
pend_splice = HsImplicitLiftSplice bind_lvl use_lvl_idx mgre name_var
=====================================
compiler/GHC/Rename/Splice.hs-boot
=====================================
@@ -2,7 +2,7 @@ module GHC.Rename.Splice where
import GHC.Hs
import GHC.Tc.Utils.Monad
-import GHC.Types.Name (Name)
+import GHC.Types.Name.Reader (WithUserRdr, GlobalRdrElt)
import GHC.Types.Name.Set
@@ -15,6 +15,6 @@ rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeNames)
rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeNames)
-checkThLocalTyName :: Name -> RnM ()
+checkThLocalTyName :: GlobalRdrElt -> RnM ()
-checkThLocalNameNoLift :: LIdOccP GhcRn -> RnM ()
+checkThLocalNameNoLift :: LocatedN (WithUserRdr GlobalRdrElt) -> RnM ()
=====================================
compiler/GHC/Rename/Unbound.hs
=====================================
@@ -11,6 +11,7 @@ module GHC.Rename.Unbound
, mkUnboundNameRdr
, mkUnboundGRE
, mkUnboundGRERdr
+ , mkUnboundGREName
, isUnboundName
, reportUnboundName
, unknownNameSuggestions
@@ -24,6 +25,8 @@ module GHC.Rename.Unbound
, LookingFor(..)
, unboundName
, unboundNameX
+ , unboundGRE
+ , unboundGREX
, unboundTermNameInTypes
, IsTermInTypes(..)
, notInScopeErr
@@ -102,14 +105,23 @@ mkUnboundNameRdr :: RdrName -> Name
mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr)
mkUnboundGRE :: OccName -> GlobalRdrElt
-mkUnboundGRE occ = mkLocalGRE UnboundGRE NoParent $ mkUnboundName occ
+mkUnboundGRE occ = mkUnboundGREName $ mkUnboundName occ
mkUnboundGRERdr :: RdrName -> GlobalRdrElt
-mkUnboundGRERdr rdr = mkLocalGRE UnboundGRE NoParent $ mkUnboundNameRdr rdr
+mkUnboundGRERdr rdr = mkUnboundGREName $ mkUnboundNameRdr rdr
+
+mkUnboundGREName :: Name -> GlobalRdrElt
+mkUnboundGREName = mkLocalGRE UnboundGRE NoParent
reportUnboundName :: WhatLooking -> RdrName -> RnM Name
reportUnboundName what_look rdr = unboundName (LF what_look WL_Anywhere) rdr
+unboundGRE :: LookingFor -> RdrName -> RnM GlobalRdrElt
+unboundGRE lf rdr = mkUnboundGREName <$> unboundName lf rdr
+
+unboundGREX :: LookingFor -> RdrName -> [GhcHint] -> RnM GlobalRdrElt
+unboundGREX lf rdr hints = mkUnboundGREName <$> unboundNameX lf rdr hints
+
unboundName :: LookingFor -> RdrName -> RnM Name
unboundName lf rdr = unboundNameX lf rdr []
=====================================
compiler/GHC/Tc/Errors.hs
=====================================
@@ -1188,8 +1188,14 @@ mkImplicitLiftingReporter ctxt
mkImplicitLiftingError :: ErrorItem -> TcRnMessage
mkImplicitLiftingError item =
case errorItemOrigin item of
- ImplicitLiftOrigin (HsImplicitLiftSplice bound used gre name) ->
- TcRnBadlyLevelled (LevelCheckSplice (getName name) gre) bound used (Just item) (cec_defer_type_errors ctxt)
+ -- mgre is Nothing IFF LevelCheckReason is LevelCheckInstance
+ ImplicitLiftOrigin (HsImplicitLiftSplice bound used (Just gre) loc_name) ->
+ TcRnBadlyLevelled
+ (LevelCheckSplice $ gre <$ unLoc loc_name)
+ bound
+ used
+ (Just item)
+ (cec_defer_type_errors ctxt)
_ -> pprPanic "mkImplicitLiftingError" (ppr item)
mkGivenErrorReporter :: Reporter
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -3465,12 +3465,16 @@ pprTcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt = mkDecorated $
(text "No instance for:" <+> quotes (ppr (errorItemPred item)))
| Just item <- [lift_attempt]
] ++
- [ vcat (text "Available from the imports:" : ppr_imports (gre_imp gre))
- | LevelCheckSplice _ (Just gre) <- [reason]
+ [ ppr_imports (gre_imp gre)
+ | LevelCheckSplice (unwrapUserRdr -> gre) <- [reason]
, not (isEmptyBag (gre_imp gre)) ]
where
- ppr_imports :: Bag ImportSpec -> [SDoc]
- ppr_imports = map ((bullet <+>) . ppr ) . bagToList
+ ppr_imports :: Bag ImportSpec -> SDoc
+ ppr_imports bag
+ | [imp] <- impspecs = pprImpSpec imp
+ | otherwise = vcat $ text "Available from the imports:" : map ((bullet <+>) . pprImpSpec) impspecs
+ where impspecs = bagToList bag
+ pprImpSpec imp = ppr imp
note :: SDoc -> SDoc
note note = "Note" <> colon <+> note <> dot
@@ -6250,8 +6254,8 @@ pprLevelCheckReason :: LevelCheckReason -> SDoc
pprLevelCheckReason = \case
LevelCheckInstance _ t ->
text "instance for" <+> quotes (ppr t)
- LevelCheckSplice t _ ->
- quotes (ppr t)
+ LevelCheckSplice t ->
+ quotes $ ppr $ userRdrName t
pprUninferrableTyVarCtx :: UninferrableTyVarCtx -> SDoc
pprUninferrableTyVarCtx = \case
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -6338,7 +6338,7 @@ data WrongThingSort
data LevelCheckReason
= LevelCheckInstance !InstanceWhat !PredType
- | LevelCheckSplice !Name !(Maybe GlobalRdrElt)
+ | LevelCheckSplice !(WithUserRdr GlobalRdrElt)
data UninferrableTyVarCtx
= UninfTyCtx_ClassContext [TcType]
=====================================
compiler/GHC/Tc/Gen/Export.hs
=====================================
@@ -540,7 +540,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
let avail = availFromGRE gre
name = greName gre
- checkThLocalNameNoLift (ieLWrappedUserRdrName l name)
+ checkThLocalNameNoLift $ ieLWrappedUserRdrName l gre
occs' <- check_occs occs ie [gre]
(export_warn_spans', dont_warn_export', warn_txt_rn)
<- process_warning export_warn_spans
@@ -589,7 +589,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
occs' <- check_occs occs ie [gre]
return (Just avail, occs', exp_dflts)
- checkThLocalNameNoLift (ieLWrappedUserRdrName l name)
+ checkThLocalNameNoLift (ieLWrappedUserRdrName l gre)
(export_warn_spans', dont_warn_export', warn_txt_rn)
<- process_warning export_warn_spans
dont_warn_export
@@ -617,7 +617,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
all_gres = par : all_kids
all_names = map greName all_gres
- checkThLocalNameNoLift (ieLWrappedUserRdrName l name)
+ checkThLocalNameNoLift (ieLWrappedUserRdrName l par)
occs' <- check_occs occs ie all_gres
(export_warn_spans', dont_warn_export', warn_txt_rn)
<- process_warning export_warn_spans
@@ -656,7 +656,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
all_gres = par : all_kids
all_names = map greName all_gres
- checkThLocalNameNoLift (ieLWrappedUserRdrName l name)
+ checkThLocalNameNoLift (ieLWrappedUserRdrName l par)
occs' <- check_occs occs ie all_gres
(export_warn_spans', dont_warn_export', warn_txt_rn)
<- process_warning export_warn_spans
@@ -794,8 +794,8 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
= addUsedGREs ExportDeprecationWarnings (pickGREs parent_rdr kid_gres)
-ieLWrappedUserRdrName :: LIEWrappedName GhcPs -> Name -> LIdOccP GhcRn
-ieLWrappedUserRdrName l n = fmap (\rdr -> WithUserRdr rdr n) $ ieLWrappedName l
+ieLWrappedUserRdrName :: LIEWrappedName GhcPs -> n -> GenLocated SrcSpanAnnN (WithUserRdr n)
+ieLWrappedUserRdrName l n = (\rdr -> WithUserRdr rdr n) <$> ieLWrappedName l
-- | In what namespaces should we go looking for an import/export item
-- that is out of scope, for suggestions in error messages?
@@ -901,7 +901,7 @@ lookupChildrenExport parent_gre child_gres rdr_items = mapAndReportM doOne rdr_i
; return (replaceLWrappedName n ub, gre)}
FoundChild child@(GRE { gre_name = child_nm, gre_par = par }) ->
do { checkPatSynParent spec_parent par child_nm
- ; checkThLocalNameNoLift (ieLWrappedUserRdrName n child_nm)
+ ; checkThLocalNameNoLift (ieLWrappedUserRdrName n child)
; return (replaceLWrappedName n child_nm, child)
}
IncorrectParent p c gs -> failWithDcErr (parentGRE_name p) (greName c) gs
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -135,7 +135,7 @@ import GHC.Types.Unique.Set ( nonDetEltsUniqSet )
import qualified GHC.LanguageExtensions as LangExt
import GHC.Iface.Errors.Types
-import GHC.Rename.Unbound ( unknownNameSuggestions )
+import GHC.Rename.Unbound ( unknownNameSuggestions, mkUnboundGREName )
import GHC.Tc.Errors.Types.PromotionErr
import {-# SOURCE #-} GHC.Tc.Errors.Hole (getHoleFitDispConfig)
@@ -252,15 +252,12 @@ tcLookupGlobal name
env <- getGblEnv
; case lookupNameEnv (tcg_type_env env) name of {
Just thing -> return thing ;
- Nothing ->
-
-- Should it have been in the local envt?
-- (NB: use semantic mod here, since names never use
-- identity module, see Note [Identity versus semantic module].)
- if nameIsLocalOrFrom (tcg_semantic_mod env) name
- then notFound name -- Internal names can happen in GHCi
- else
-
+ Nothing | nameIsLocalOrFrom (tcg_semantic_mod env) name ->
+ notFound $ mkUnboundGREName name -- Internal names can happen in GHCi
+ | otherwise ->
-- Try home package table and external package table
do { mb_thing <- tcLookupImported_maybe name
; case mb_thing of
@@ -1221,10 +1218,10 @@ pprBinders :: [Name] -> SDoc
pprBinders [bndr] = quotes (ppr bndr)
pprBinders bndrs = pprWithCommas ppr bndrs
-notFound :: Name -> TcM TyThing
-notFound name
+notFound :: GlobalRdrElt -> TcM TyThing
+notFound gre
= do { lcl_env <- getLclEnv
- ; lvls <- getCurrentAndBindLevel name
+ ; lvls <- getCurrentAndBindLevel gre
; if -- See Note [Out of scope might be a staging error]
| isUnboundName name -> failM -- If the name really isn't in scope
-- don't report it again (#11941)
@@ -1234,8 +1231,13 @@ notFound name
-- introducing bugs after a refactoring of that
-- function, we check this completely independently
-- before scrutinizing lvls
- | Just (_top_lvl_flag, bind_lvls, lvl@Splice {}) <- lvls
- -> failWithTc (TcRnBadlyLevelled (LevelCheckSplice name Nothing) bind_lvls (thLevelIndex lvl) Nothing ErrorWithoutFlag)
+ | Just (_top_lvl_flag, bind_lvls, lvl@Splice {}) <- lvls -> failWithTc $
+ TcRnBadlyLevelled
+ (LevelCheckSplice (gre <$ noUserRdr name))
+ bind_lvls
+ (thLevelIndex lvl)
+ Nothing
+ ErrorWithoutFlag
| otherwise -> pure ()
; if isTermVarOrFieldNameSpace (nameNameSpace name)
@@ -1260,6 +1262,7 @@ notFound name
-- so let's just not print it! Getting a loop here is
-- very unhelpful, because it hides one compiler bug with another
}
+ where name = greName gre
wrongThingErr :: WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr expected thing name =
=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -2468,32 +2468,22 @@ keepAlive name
getThLevel :: TcM ThLevel
getThLevel = do { env <- getLclEnv; return (getLclEnvThLevel env) }
-getCurrentAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, Set.Set ThLevelIndex, ThLevel))
-getCurrentAndBindLevel name
+getCurrentAndBindLevel :: GlobalRdrElt -> TcRn (Maybe (TopLevelFlag, Set.Set ThLevelIndex, ThLevel))
+getCurrentAndBindLevel gre
= do { env <- getLclEnv;
- ; case lookupNameEnv (getLclEnvThBndrs env) name of
- Nothing -> do
- lvls <- getExternalBindLvl name
- if Set.empty == lvls
- -- This case happens when code is generated for identifiers which are not
- -- in scope.
- --
- -- TODO: What happens if someone generates [|| GHC.Magic.dataToTag# ||]
- then do
- return Nothing
- else return (Just (TopLevel, lvls, getLclEnvThLevel env))
- Just (top_lvl, bind_lvl) -> return (Just (top_lvl, Set.singleton bind_lvl, getLclEnvThLevel env)) }
-
-getExternalBindLvl :: Name -> TcRn (Set.Set ThLevelIndex)
-getExternalBindLvl name = do
- env <- getGlobalRdrEnv
- mod <- getModule
- case lookupGRE_Name env name of
- Just gre -> return $ (Set.map thLevelIndexFromImportLevel (greLevels gre))
- Nothing ->
- if nameIsLocalOrFrom mod name
- then return $ Set.singleton topLevelIndex
- else return Set.empty
+ ; return $ case lookupNameEnv (getLclEnvThBndrs env) $ greName gre of
+ Nothing
+ | Set.null lvls -> Nothing
+ -- This case happens when code is generated for identifiers which are not
+ -- in scope.
+ --
+ -- TODO: What happens if someone generates [|| GHC.Magic.dataToTag# ||]
+ | otherwise -> Just (TopLevel, lvls, getLclEnvThLevel env)
+ Just (top_lvl, bind_lvl) -> Just (top_lvl, Set.singleton bind_lvl, getLclEnvThLevel env) }
+ where lvls = getExternalBindLvl gre
+
+getExternalBindLvl :: GlobalRdrElt -> Set.Set ThLevelIndex
+getExternalBindLvl gre = Set.map thLevelIndexFromImportLevel (greLevels gre)
setThLevel :: ThLevel -> TcM a -> TcRn a
setThLevel l = updLclEnv (setLclEnvThLevel l)
=====================================
compiler/GHC/Types/Name/Reader.hs
=====================================
@@ -40,7 +40,7 @@ module GHC.Types.Name.Reader (
isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName,
-- ** Preserving user-written qualification
- WithUserRdr(..), noUserRdr, unLocWithUserRdr, userRdrName,
+ WithUserRdr(..), noUserRdr, unLocWithUserRdr, userRdrName, unwrapUserRdr,
-- * Local mapping of 'RdrName' to 'Name.Name'
LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,
@@ -2247,9 +2247,12 @@ unLocWithUserRdr (L _ (WithUserRdr _ a)) = a
noUserRdr :: Name -> WithUserRdr Name
noUserRdr n = WithUserRdr (nameRdrName n) n
-userRdrName :: WithUserRdr Name -> RdrName
+userRdrName :: WithUserRdr a -> RdrName
userRdrName (WithUserRdr rdr _) = rdr
+unwrapUserRdr :: WithUserRdr a -> a
+unwrapUserRdr (WithUserRdr _ a) = a
+
rdrQual_maybe :: RdrName -> Maybe ModuleName
rdrQual_maybe = \case
Qual q _ -> Just q
=====================================
testsuite/tests/quotes/LiftErrMsg.stderr
=====================================
@@ -2,8 +2,7 @@ LiftErrMsg.hs:14:11: error: [GHC-28914]
• Level error: ‘id’ is bound at level 0 but used at level 1
• Could not be resolved by implicit lifting due to the following error:
No instance for: ‘Lift (a2 -> a2)’
- • Available from the imports:
- • imported from ‘Prelude’
+ • imported from ‘Prelude’
• In the expression: [| id |]
In an equation for ‘test’: test = [| id |]
@@ -11,8 +10,7 @@ LiftErrMsg.hs:17:13: error: [GHC-28914]
• Level error: ‘id’ is bound at level 0 but used at level 1
• Could not be resolved by implicit lifting due to the following error:
No instance for: ‘Lift (a1 -> a1)’
- • Available from the imports:
- • imported from ‘Prelude’
+ • imported from ‘Prelude’
• In the expression: [| (id, id) |]
In an equation for ‘test2’: test2 = [| (id, id) |]
@@ -20,8 +18,7 @@ LiftErrMsg.hs:17:17: error: [GHC-28914]
• Level error: ‘id’ is bound at level 0 but used at level 1
• Could not be resolved by implicit lifting due to the following error:
No instance for: ‘Lift (a0 -> a0)’
- • Available from the imports:
- • imported from ‘Prelude’
+ • imported from ‘Prelude’
• In the expression: [| (id, id) |]
In an equation for ‘test2’: test2 = [| (id, id) |]
=====================================
testsuite/tests/quotes/LiftErrMsgDefer.stderr
=====================================
@@ -4,12 +4,11 @@ LiftErrMsgDefer.hs:14:12: warning: [GHC-28914] [-Wdeferred-type-errors (in -Wdef
• Level error: ‘id’ is bound at level 0 but used at level 1
• Could not be resolved by implicit lifting due to the following error:
No instance for: ‘Lift (a2 -> a2)’
- • Available from the imports:
- • imported from ‘Prelude’
+ • imported from ‘Prelude’
• In the expression: [| id |]
In an equation for ‘test1’: test1 = [| id |]
(deferred type error)
HasCallStack backtrace:
- throw, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:435:30 in ghc-internal:GHC.Internal.Control.Exception.Base
+ throw, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:441:30 in ghc-internal:GHC.Internal.Control.Exception.Base
=====================================
testsuite/tests/quotes/LiftErrMsgTyped.stderr
=====================================
@@ -2,8 +2,7 @@ LiftErrMsgTyped.hs:14:12: error: [GHC-28914]
• Level error: ‘id’ is bound at level 0 but used at level 1
• Could not be resolved by implicit lifting due to the following error:
No instance for: ‘Lift (a -> a)’
- • Available from the imports:
- • imported from ‘Prelude’
+ • imported from ‘Prelude’
• In the typed Template Haskell splice: id
In the Template Haskell typed quotation: [|| id ||]
In the expression: [|| id ||]
@@ -12,8 +11,7 @@ LiftErrMsgTyped.hs:17:14: error: [GHC-28914]
• Level error: ‘id’ is bound at level 0 but used at level 1
• Could not be resolved by implicit lifting due to the following error:
No instance for: ‘Lift (a -> a)’
- • Available from the imports:
- • imported from ‘Prelude’
+ • imported from ‘Prelude’
• In the typed Template Haskell splice: id
In the expression: id
In the Template Haskell typed quotation: [|| (id, id) ||]
=====================================
testsuite/tests/splice-imports/SI03.stderr
=====================================
@@ -1,6 +1,5 @@
SI03.hs:10:11: error: [GHC-28914]
• Level error: ‘sid’ is bound at level 0 but used at level -1
- • Available from the imports:
- • imported from ‘SI01A’ at SI03.hs:5:1-12
+ • imported from ‘SI01A’ at SI03.hs:5:1-12
• In the untyped splice: $(sid [| pure () |])
=====================================
testsuite/tests/splice-imports/SI05.stderr
=====================================
@@ -1,7 +1,6 @@
SI05.hs:10:11: error: [GHC-28914]
- • Level error: ‘SI01A.sid’ is bound at level 0 but used at level -1
- • Available from the imports:
- • imported from ‘SI01A’ at SI05.hs:6:1-12
+ • Level error: ‘sid’ is bound at level 0 but used at level -1
+ • imported from ‘SI01A’ at SI05.hs:6:1-12
• In the untyped splice: $(sid [| pure () |])
SI05.hs:10:11: error: [GHC-87543]
=====================================
testsuite/tests/splice-imports/SI25.stderr
=====================================
@@ -1,8 +1,7 @@
SI25.hs:16:13: error: [GHC-28914]
• Level error: ‘nestedCode’ is bound at level -1
but used at level -2
- • Available from the imports:
- • imported from ‘SI25Helper’ at -1 at SI25.hs:6:1-24
+ • imported from ‘SI25Helper’ at -1 at SI25.hs:6:1-24
• In the untyped splice: $(nestedCode "nested")
In the untyped splice: $($(nestedCode "nested"))
=====================================
testsuite/tests/splice-imports/SI28.stderr
=====================================
@@ -1,7 +1,6 @@
SI28.hs:8:13: error: [GHC-28914]
• Level error: ‘id’ is bound at level 1 but used at level 0
- • Available from the imports:
- • imported from ‘Prelude’ at 1 at SI28.hs:6:1-20
+ • imported from ‘Prelude’ at 1 at SI28.hs:6:1-20
• In the Template Haskell quotation: [| id |]
In the untyped splice: $([| id |])
=====================================
testsuite/tests/splice-imports/SI31.stderr
=====================================
@@ -1,6 +1,5 @@
<interactive>:2:3: error: [GHC-28914]
• Level error: ‘id’ is bound at level 0 but used at level -1
- • Available from the imports:
- • imported from ‘Prelude’
+ • imported from ‘Prelude’
• In the untyped splice: $(id [| () |])
=====================================
testsuite/tests/splice-imports/T26088.stderr
=====================================
@@ -1,6 +1,5 @@
T26088A.hs:8:8: error: [GHC-28914]
• Level error: ‘a’ is bound at level -1 but used at level 1
- • Available from the imports:
- • imported from ‘T26088B’ at -1 at T26088A.hs:4:1-21
+ • imported from ‘T26088B’ at -1 at T26088A.hs:4:1-21
• In the Template Haskell quotation: [| a |]
=====================================
testsuite/tests/splice-imports/T26090.stderr
=====================================
@@ -1,16 +1,13 @@
T26090.hs:2:17: error: [GHC-28914]
• Level error: ‘a’ is bound at level 1 but used at level 0
- • Available from the imports:
- • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20
+ • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20
T26090.hs:4:17: error: [GHC-28914]
• Level error: ‘s’ is bound at level 1 but used at level 0
- • Available from the imports:
- • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20
+ • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20
• In the export: S(s)
T26090.hs:5:17: error: [GHC-28914]
• Level error: ‘R’ is bound at level 1 but used at level 0
- • Available from the imports:
- • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20
+ • imported from ‘T26090A’ at 1 at T26090.hs:8:1-20
=====================================
testsuite/tests/splice-imports/T26616.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE ExplicitLevelImports, NoImplicitPrelude #-}
+module T26616 where
+
+import quote Data.Maybe qualified as Q
+import Data.Maybe qualified as Z
+import splice Data.Maybe qualified as S
+
+foo = Q.isJust
=====================================
testsuite/tests/splice-imports/T26616.stderr
=====================================
@@ -0,0 +1,4 @@
+T26616.hs:8:7: error: [GHC-28914]
+ • Level error: ‘Q.isJust’ is bound at level 1 but used at level 0
+ • imported qualified from ‘Data.Maybe’ at 1 at T26616.hs:4:1-39
+
=====================================
testsuite/tests/splice-imports/all.T
=====================================
@@ -52,3 +52,4 @@ test('T26090', [], multimod_compile_fail, ['T26090', '-v0'])
test('ModuleExport', [], multimod_compile_fail, ['ModuleExport', '-v0'])
test('LevelImportExports', [], makefile_test, [])
test('DodgyLevelExport', [], multimod_compile, ['DodgyLevelExport', '-v0 -Wdodgy-exports'])
+test('T26616', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/462ffb0b9d7ec0661f2f7928a8bf6e5…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/462ffb0b9d7ec0661f2f7928a8bf6e5…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/deduplicate-hsc-tidy] compiler: Deduplicate hscTidy
by Andreas Klebinger (＠AndreasK) 16 Jun '26
by Andreas Klebinger (＠AndreasK) 16 Jun '26
16 Jun '26
Andreas Klebinger pushed to branch wip/andreask/deduplicate-hsc-tidy at Glasgow Haskell Compiler / GHC
Commits:
7e8b0d01 by Andreas Klebinger at 2026-06-16T10:36:13+02:00
compiler: Deduplicate hscTidy
This function was accidentally duplicated during a refactor.
Fixes #27351
- - - - -
3 changed files:
- compiler/GHC/Driver/Main/Interactive.hs
- compiler/GHC/Driver/Main/Passes.hs
- compiler/GHC/Driver/Main/Passes.hs-boot
Changes:
=====================================
compiler/GHC/Driver/Main/Interactive.hs
=====================================
@@ -31,7 +31,6 @@ module GHC.Driver.Main.Interactive
, hscParseExpr
, hscParseType
, hscCompileCoreExpr
- , hscTidy
) where
@@ -39,7 +38,7 @@ import GHC.Prelude
import GHC.Driver.Main.Hsc
import {-# SOURCE #-} GHC.Driver.Main.Passes
- ( hscDesugar', hscSimplify, hscCompileCoreExpr )
+ ( hscDesugar', hscSimplify, hscTidy, hscCompileCoreExpr )
import {-# SOURCE #-} GHC.Driver.Main.Compile
( mkCgInteractiveGuts, generateFreshByteCodeLinkable )
@@ -47,11 +46,9 @@ import {-# SOURCE #-} GHC.Driver.Main.Compile
import GHC.Driver.Session
import GHC.Driver.Env
import GHC.Driver.Errors.Types
-import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO )
import GHC.Driver.Config.Core.Lint.Interactive ( lintInteractiveExpr )
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Driver.Config.Diagnostic
-import GHC.Driver.Config.Tidy
import GHC.Runtime.Context
import GHCi.RemoteTypes
@@ -66,16 +63,12 @@ import GHC.HsToCore
import GHC.Iface.Load ( loadSysInterface )
-import GHC.Iface.Tidy
import GHC.Core
import GHC.Core.ConLike
-import GHC.Core.Opt.Pipeline.Types ( CoreToDo (..))
import GHC.Core.TyCon
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
-import GHC.Core.Rules
-import GHC.Core.Stats
import GHC.Parser.Errors.Types
import GHC.Parser
@@ -570,43 +563,3 @@ hscParseThingWithLocation source linenumber parser str = do
FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing)
return thing
-hscTidy :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
-hscTidy hsc_env guts = do
- let logger = hsc_logger hsc_env
- let this_mod = mg_module guts
-
- opts <- initTidyOpts hsc_env
- (cgguts, details) <- withTiming logger
- (text "CoreTidy"<+>brackets (ppr this_mod))
- (const ())
- $! {-# SCC "CoreTidy" #-} tidyProgram opts guts
-
- -- post tidy pretty-printing and linting...
- let tidy_rules = md_rules details
- let all_tidy_binds = cg_binds cgguts
- let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
- ptc = initPromotionTickContext (hsc_dflags hsc_env)
-
- endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
-
- -- If the endPass didn't print the rules, but ddump-rules is
- -- on, print now
- unless (logHasDumpFlag logger Opt_D_dump_simpl) $
- putDumpFileMaybe logger Opt_D_dump_rules
- "Tidy Core rules"
- FormatText
- (pprRulesForUser tidy_rules)
-
- -- Print one-line size info
- let cs = coreBindsStats all_tidy_binds
- putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats"
- FormatText
- (text "Tidy size (terms,types,coercions)"
- <+> ppr (moduleName this_mod) <> colon
- <+> int (cs_tm cs)
- <+> int (cs_ty cs)
- <+> int (cs_co cs))
-
- pure (cgguts, details)
-
-
=====================================
compiler/GHC/Driver/Main/Passes.hs
=====================================
@@ -29,6 +29,7 @@ module GHC.Driver.Main.Passes
, hscSimplify
, hscSimplify'
, hscDesugarAndSimplify
+ , hscTidy
) where
=====================================
compiler/GHC/Driver/Main/Passes.hs-boot
=====================================
@@ -7,6 +7,7 @@ module GHC.Driver.Main.Passes
, hscDesugar'
, hscSimplify
+ , hscTidy
) where
@@ -24,9 +25,11 @@ import GHC.Tc.Utils.Monad
import GHC.Unit
import GHC.Unit.Module.ModGuts
+import GHC.Unit.Module.ModDetails
import GHC.Types.SrcLoc
hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts
hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [LinkableUsage], PkgsLoaded)
+hscTidy :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7e8b0d017e62ada58917886355a9b79…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7e8b0d017e62ada58917886355a9b79…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: base: more NonEmpty zips
by Marge Bot (＠marge-bot) 16 Jun '26
by Marge Bot (＠marge-bot) 16 Jun '26
16 Jun '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
893e6133 by Andrew Lelechenko at 2026-06-15T23:55:36+01:00
base: more NonEmpty zips
CLC proposal: https://github.com/haskell/core-libraries-committee/issues/409
- - - - -
8db2928a by David Eichmann at 2026-06-16T00:15:31-04:00
Hadrian: fix ghc-internal .def file name
- - - - -
4fc0765e by mangoiv at 2026-06-16T00:15:32-04:00
compiler: ignore camelCase and Eta reduce hlint hints
These do not cohere with the style used in GHC. After disabling them,
hlint lints are much less noisy again.
- - - - -
8c3af523 by Alan Zimmerman at 2026-06-16T00:15:33-04:00
EPA: Use standard type family declaration for Anno
- - - - -
9 changed files:
- compiler/.hlint.yaml
- compiler/GHC/Data/List/NonEmpty.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- hadrian/src/Rules/Rts.hs
- libraries/base/changelog.md
- libraries/base/src/Data/List/NonEmpty.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
Changes:
=====================================
compiler/.hlint.yaml
=====================================
@@ -3,6 +3,8 @@
##########################
- ignore: {}
+- ignore: {name: Use camelCase}
+- ignore: {name: Eta reduce}
- warn: {name: Unused LANGUAGE pragma}
- warn: {name: Use fewer LANGUAGE pragmas}
- warn: {name: Redundant return}
=====================================
compiler/GHC/Data/List/NonEmpty.hs
=====================================
@@ -1,10 +1,11 @@
+{-# OPTIONS_GHC -Wno-dodgy-imports #-}
module GHC.Data.List.NonEmpty (module Data.List.NonEmpty, module GHC.Data.List.NonEmpty, toList) where
import Prelude (Bool, (.))
import Control.Applicative
import qualified Control.Monad as List (zipWithM)
import Data.Foldable (Foldable (toList))
-import Data.List.NonEmpty hiding (toList, unzip)
+import Data.List.NonEmpty hiding (toList, unzip, unzip3)
import qualified Data.List as List
import qualified GHC.Data.List as List
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -108,7 +108,7 @@ dataConCantHappen x = case x of {}
-- See Note [XRec and SrcSpans in the AST]
type family XRec p a = r | r -> a
-type family Anno a = b -- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation
+type family Anno a -- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation
{-
Note [XRec and SrcSpans in the AST]
=====================================
hadrian/src/Rules/Rts.hs
=====================================
@@ -25,7 +25,7 @@ buildGhcInternalImportDef target = do
buildGhcInternalImportLib :: FilePath -> Action ()
buildGhcInternalImportLib target = do
- let input = dropExtensions target <.> "def" -- the .def file
+ let input = dropExtension (dropExtension target) <.> "def" -- the .def file
output = target -- the .dll.a import lib
need [input]
runBuilder Dlltool ["-d", input, "-l", output] [input] [output]
=====================================
libraries/base/changelog.md
=====================================
@@ -2,6 +2,7 @@
## 4.24.0.0 *TBA*
* Add `Bounded` instances for `Double`, `Float`, `CDouble` and `CFloat`. ([CLC proposal #402](https://github.com/haskell/core-libraries-committee/issues/402))
+ * Add `Data.List.NonEmpty.{zip{3..7},zipWith{3..7},unzip{3..7}}` ([CLC proposal #409)(https://github.com/haskell/core-libraries-committee/issues/409))
* Ensure that `Data.List.elem` and `notElem` can be specialized even when no list fusion happens. ([CLC proposal #412)(https://github.com/haskell/core-libraries-committee/issues/412))
* Introduce `Data.Double` and `Data.Float` modules. ([CLC proposal #378](https://github.com/haskell/core-libraries-committee/issues/378))
=====================================
libraries/base/src/Data/List/NonEmpty.hs
=====================================
@@ -99,10 +99,29 @@ module Data.List.NonEmpty (
, nubOrdBy -- :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
-- * Indexing streams
, (!!) -- :: NonEmpty a -> Int -> a
+
-- * Zipping and unzipping streams
- , zip -- :: NonEmpty a -> NonEmpty b -> NonEmpty (a,b)
- , zipWith -- :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
- , unzip -- :: Functor f => f (a,b) -> (f a, f b)
+ , zip
+ , zip3
+ , zip4
+ , zip5
+ , zip6
+ , zip7
+
+ , zipWith
+ , zipWith3
+ , zipWith4
+ , zipWith5
+ , zipWith6
+ , zipWith7
+
+ , unzip
+ , unzip3
+ , unzip4
+ , unzip5
+ , unzip6
+ , unzip7
+
-- * Converting to and from a list
, fromList -- :: [a] -> NonEmpty a
, toList -- :: NonEmpty a -> [a]
@@ -116,7 +135,7 @@ import Prelude hiding (break, cycle, drop, dropWhile,
last, length, map, repeat, reverse,
scanl, scanl1, scanr, scanr1, span,
splitAt, tail, take, takeWhile,
- unzip, zip, zipWith, (!!), Applicative(..))
+ unzip, unzip3, zip, zip3, zipWith, zipWith3, (!!), Applicative(..))
import qualified Prelude
import Control.Applicative (Applicative (..), Alternative (many))
@@ -560,12 +579,97 @@ isPrefixOf (y:ys) (x :| xs) = (y == x) && List.isPrefixOf ys xs
| otherwise = error "NonEmpty.!! negative index"
infixl 9 !!
+-- | The 'zip3' function takes three streams and returns a stream of
+-- corresponding triples.
+zip3 :: NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty (a, b, c)
+zip3 (x :| xs) (y :| ys) (z :| zs) = (x, y, z) :| List.zip3 xs ys zs
+
+-- | The 'zip4' function takes four streams and returns a stream of
+-- corresponding quadruples.
+zip4 :: NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty (a, b, c, d)
+zip4 (x :| xs) (y :| ys) (z :| zs) (t :| ts) = (x, y, z, t) :| List.zip4 xs ys zs ts
+
+-- | The 'zip5' function takes five streams and returns a stream of
+-- corresponding quintuples.
+zip5 :: NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty (a, b, c, d, e)
+zip5 (x :| xs) (y :| ys) (z :| zs) (t :| ts) (u :| us) = (x, y, z, t, u) :| List.zip5 xs ys zs ts us
+
+-- | The 'zip6' function takes six streams and returns a stream of
+-- corresponding sextuples.
+zip6 :: NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty (a, b, c, d, e, f)
+zip6 (x :| xs) (y :| ys) (z :| zs) (t :| ts) (u :| us) (v :| vs) = (x, y, z, t, u, v) :| List.zip6 xs ys zs ts us vs
+
+-- | The 'zip7' function takes seven streams and returns a stream of
+-- corresponding septuples.
+zip7 :: NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g -> NonEmpty (a, b, c, d, e, f, g)
+zip7 (x :| xs) (y :| ys) (z :| zs) (t :| ts) (u :| us) (v :| vs) (w :| ws) = (x, y, z, t, u, v, w) :| List.zip7 xs ys zs ts us vs ws
+
+-- | The 'zipWith3' function generalizes 'zip3'. Rather than tupling
+-- the elements, the elements are combined using the function
+-- passed as the first argument.
+zipWith3 :: (a -> b -> c -> d) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d
+zipWith3 f (x :| xs) (y :| ys) (z :| zs) = f x y z :| List.zipWith3 f xs ys zs
+
+-- | The 'zipWith4' function generalizes 'zip4'. Rather than tupling
+-- the elements, the elements are combined using the function
+-- passed as the first argument.
+zipWith4 :: (a -> b -> c -> d -> e) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e
+zipWith4 f (x :| xs) (y :| ys) (z :| zs) (t :| ts) = f x y z t :| List.zipWith4 f xs ys zs ts
+
+-- | The 'zipWith5' function generalizes 'zip5'. Rather than tupling
+-- the elements, the elements are combined using the function
+-- passed as the first argument.
+zipWith5 :: (a -> b -> c -> d -> e -> f) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f
+zipWith5 f (x :| xs) (y :| ys) (z :| zs) (t :| ts) (u :| us) = f x y z t u :| List.zipWith5 f xs ys zs ts us
+
+-- | The 'zipWith6' function generalizes 'zip6'. Rather than tupling
+-- the elements, the elements are combined using the function
+-- passed as the first argument.
+zipWith6 :: (a -> b -> c -> d -> e -> f -> g) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g
+zipWith6 f (x :| xs) (y :| ys) (z :| zs) (t :| ts) (u :| us) (v :| vs) = f x y z t u v :| List.zipWith6 f xs ys zs ts us vs
+
+-- | The 'zipWith7' function generalizes 'zip7'. Rather than tupling
+-- the elements, the elements are combined using the function
+-- passed as the first argument.
+zipWith7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g -> NonEmpty h
+zipWith7 f (x :| xs) (y :| ys) (z :| zs) (t :| ts) (u :| us) (v :| vs) (w :| ws) = f x y z t u v w :| List.zipWith7 f xs ys zs ts us vs ws
+
-- | The 'unzip' function is the inverse of the 'zip' function.
unzip :: NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)
unzip ((a, b) :| asbs) = (a :| as, b :| bs)
where
(as, bs) = List.unzip asbs
+-- | The 'unzip3' function is the inverse of the 'zip3' function.
+unzip3 :: NonEmpty (a, b, c) -> (NonEmpty a, NonEmpty b, NonEmpty c)
+unzip3 ((a, b, c) :| asbscs) = (a :| as, b :| bs, c :| cs)
+ where
+ (as, bs, cs) = List.unzip3 asbscs
+
+-- | The 'unzip4' function is the inverse of the 'zip4' function.
+unzip4 :: NonEmpty (a, b, c, d) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d)
+unzip4 ((a, b, c, d) :| asbscsds) = (a :| as, b :| bs, c :| cs, d :| ds)
+ where
+ (as, bs, cs, ds) = List.unzip4 asbscsds
+
+-- | The 'unzip5' function is the inverse of the 'zip5' function.
+unzip5 :: NonEmpty (a, b, c, d, e) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e)
+unzip5 ((a, b, c, d, e) :| asbscsdses) = (a :| as, b :| bs, c :| cs, d :| ds, e :| es)
+ where
+ (as, bs, cs, ds, es) = List.unzip5 asbscsdses
+
+-- | The 'unzip6' function is the inverse of the 'zip6' function.
+unzip6 :: NonEmpty (a, b, c, d, e, f) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e, NonEmpty f)
+unzip6 ((a, b, c, d, e, f) :| asbscsdsesfs) = (a :| as, b :| bs, c :| cs, d :| ds, e :| es, f :| fs)
+ where
+ (as, bs, cs, ds, es, fs) = List.unzip6 asbscsdsesfs
+
+-- | The 'unzip7' function is the inverse of the 'zip7' function.
+unzip7 :: NonEmpty (a, b, c, d, e, f, g) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e, NonEmpty f, NonEmpty g)
+unzip7 ((a, b, c, d, e, f, g) :| asbscsdsesfsgs) = (a :| as, b :| bs, c :| cs, d :| ds, e :| es, f :| fs, g :| gs)
+ where
+ (as, bs, cs, ds, es, fs, gs) = List.unzip7 asbscsdsesfsgs
+
-- | The 'nub' function removes duplicate elements from a list. In
-- particular, it keeps only the first occurrence of each element.
-- (The name 'nub' means \'essence\'.)
=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -1521,9 +1521,24 @@ module Data.List.NonEmpty where
unfold :: forall a b. (a -> (b, GHC.Internal.Maybe.Maybe a)) -> a -> NonEmpty b
unfoldr :: forall a b. (a -> (b, GHC.Internal.Maybe.Maybe a)) -> a -> NonEmpty b
unzip :: forall a b. NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)
+ unzip3 :: forall a b c. NonEmpty (a, b, c) -> (NonEmpty a, NonEmpty b, NonEmpty c)
+ unzip4 :: forall a b c d. NonEmpty (a, b, c, d) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d)
+ unzip5 :: forall a b c d e. NonEmpty (a, b, c, d, e) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e)
+ unzip6 :: forall a b c d e f. NonEmpty (a, b, c, d, e, f) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e, NonEmpty f)
+ unzip7 :: forall a b c d e f g. NonEmpty (a, b, c, d, e, f, g) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e, NonEmpty f, NonEmpty g)
xor :: NonEmpty GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool
zip :: forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
+ zip3 :: forall a b c. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty (a, b, c)
+ zip4 :: forall a b c d. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty (a, b, c, d)
+ zip5 :: forall a b c d e. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty (a, b, c, d, e)
+ zip6 :: forall a b c d e f. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty (a, b, c, d, e, f)
+ zip7 :: forall a b c d e f g. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g -> NonEmpty (a, b, c, d, e, f, g)
zipWith :: forall a b c. (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
+ zipWith3 :: forall a b c d. (a -> b -> c -> d) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d
+ zipWith4 :: forall a b c d e. (a -> b -> c -> d -> e) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e
+ zipWith5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f
+ zipWith6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g
+ zipWith7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g -> NonEmpty h
module Data.Maybe where
-- Safety: Safe
=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -1521,9 +1521,24 @@ module Data.List.NonEmpty where
unfold :: forall a b. (a -> (b, GHC.Internal.Maybe.Maybe a)) -> a -> NonEmpty b
unfoldr :: forall a b. (a -> (b, GHC.Internal.Maybe.Maybe a)) -> a -> NonEmpty b
unzip :: forall a b. NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)
+ unzip3 :: forall a b c. NonEmpty (a, b, c) -> (NonEmpty a, NonEmpty b, NonEmpty c)
+ unzip4 :: forall a b c d. NonEmpty (a, b, c, d) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d)
+ unzip5 :: forall a b c d e. NonEmpty (a, b, c, d, e) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e)
+ unzip6 :: forall a b c d e f. NonEmpty (a, b, c, d, e, f) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e, NonEmpty f)
+ unzip7 :: forall a b c d e f g. NonEmpty (a, b, c, d, e, f, g) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e, NonEmpty f, NonEmpty g)
xor :: NonEmpty GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool
zip :: forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
+ zip3 :: forall a b c. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty (a, b, c)
+ zip4 :: forall a b c d. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty (a, b, c, d)
+ zip5 :: forall a b c d e. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty (a, b, c, d, e)
+ zip6 :: forall a b c d e f. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty (a, b, c, d, e, f)
+ zip7 :: forall a b c d e f g. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g -> NonEmpty (a, b, c, d, e, f, g)
zipWith :: forall a b c. (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
+ zipWith3 :: forall a b c d. (a -> b -> c -> d) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d
+ zipWith4 :: forall a b c d e. (a -> b -> c -> d -> e) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e
+ zipWith5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f
+ zipWith6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g
+ zipWith7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g -> NonEmpty h
module Data.Maybe where
-- Safety: Safe
=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -1521,9 +1521,24 @@ module Data.List.NonEmpty where
unfold :: forall a b. (a -> (b, GHC.Internal.Maybe.Maybe a)) -> a -> NonEmpty b
unfoldr :: forall a b. (a -> (b, GHC.Internal.Maybe.Maybe a)) -> a -> NonEmpty b
unzip :: forall a b. NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)
+ unzip3 :: forall a b c. NonEmpty (a, b, c) -> (NonEmpty a, NonEmpty b, NonEmpty c)
+ unzip4 :: forall a b c d. NonEmpty (a, b, c, d) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d)
+ unzip5 :: forall a b c d e. NonEmpty (a, b, c, d, e) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e)
+ unzip6 :: forall a b c d e f. NonEmpty (a, b, c, d, e, f) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e, NonEmpty f)
+ unzip7 :: forall a b c d e f g. NonEmpty (a, b, c, d, e, f, g) -> (NonEmpty a, NonEmpty b, NonEmpty c, NonEmpty d, NonEmpty e, NonEmpty f, NonEmpty g)
xor :: NonEmpty GHC.Internal.Types.Bool -> GHC.Internal.Types.Bool
zip :: forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
+ zip3 :: forall a b c. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty (a, b, c)
+ zip4 :: forall a b c d. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty (a, b, c, d)
+ zip5 :: forall a b c d e. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty (a, b, c, d, e)
+ zip6 :: forall a b c d e f. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty (a, b, c, d, e, f)
+ zip7 :: forall a b c d e f g. NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g -> NonEmpty (a, b, c, d, e, f, g)
zipWith :: forall a b c. (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
+ zipWith3 :: forall a b c d. (a -> b -> c -> d) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d
+ zipWith4 :: forall a b c d e. (a -> b -> c -> d -> e) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e
+ zipWith5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f
+ zipWith6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g
+ zipWith7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty e -> NonEmpty f -> NonEmpty g -> NonEmpty h
module Data.Maybe where
-- Safety: Safe
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/903801491a2e26897017b4e60b630b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/903801491a2e26897017b4e60b630b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc] Pushed new branch wip/sjakobi/analyze-uniq-sets
by Simon Jakobi (＠sjakobi2) 16 Jun '26
by Simon Jakobi (＠sjakobi2) 16 Jun '26
16 Jun '26
Simon Jakobi pushed new branch wip/sjakobi/analyze-uniq-sets at Glasgow Haskell Compiler / GHC
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/analyze-uniq-sets
You're receiving this email because of your account on gitlab.haskell.org.
1
0