[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 3 commits: Elaborate on the quantified superclass of Bifunctor
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Nov 7 04:39:57 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
f4b8a257 by Tobias Haslop at 2023-11-06T23:39:41-05:00
Elaborate on the quantified superclass of Bifunctor
This was requested in the comment
https://github.com/haskell/core-libraries-committee/issues/93#issuecomment-1597271700
for when Traversable becomes a superclass of Bitraversable, but similarly
applies to Functor/Bifunctor, which already are in a superclass relationship.
- - - - -
fe929bd0 by Alan Zimmerman at 2023-11-06T23:39:41-05:00
EPA: get rid of l2l and friends
Replace them with
l2l to convert the location
la2la to convert a GenLocated thing
Updates haddock submodule
- - - - -
1163a38a by Luite Stegeman at 2023-11-06T23:39:44-05:00
JS: remove broken newIdents from JStg Monad
GHC.JS.JStg.Monad.newIdents was broken, resulting in duplicate
identifiers being generated in h$c1, h$c2, ... .
This change removes the broken newIdents.
- - - - -
19 changed files:
- compiler/GHC/JS/JStg/Monad.hs
- compiler/GHC/JS/Make.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/TyCl/Class.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
- libraries/base/src/Data/Bifunctor.hs
- utils/haddock
Changes:
=====================================
compiler/GHC/JS/JStg/Monad.hs
=====================================
@@ -40,7 +40,6 @@ module GHC.JS.JStg.Monad
, JSM
, withTag
, newIdent
- , newIdents
, initJSM
) where
@@ -95,19 +94,6 @@ newIdent = do env <- get
mk_ident :: FastString -> Unique -> Ident
mk_ident t i = global (mconcat [t, "_", mkFastString (show i)])
-
-
--- | A special case optimization over @newIdent at . Given a number of @Ident@ to
--- generate, generate all of them at one time and update the state once rather
--- than n times.
-newIdents :: Int -> JSM [Ident]
-newIdents 0 = return []
-newIdents n = do env <- get
- let is = take n (uniqsFromSupply $ ids env)
- tag = prefix env
- return $ fmap (mk_ident tag) is
-
-
-- | Set the tag for @Ident at s for all remaining computations.
tag_names :: FastString -> JSM ()
tag_names tag = modify' (\env -> env {prefix = tag})
=====================================
compiler/GHC/JS/Make.hs
=====================================
@@ -149,6 +149,7 @@ import GHC.JS.JStg.Monad
import GHC.JS.Transform
import Control.Arrow ((***))
+import Control.Monad (replicateM)
import Data.Tuple
import qualified Data.Map as M
@@ -325,7 +326,7 @@ jFunctionSized
-> ([JStgExpr] -> JSM JStgStat) -- ^ function body, input is locally unique generated variables
-> JSM JStgStat
jFunctionSized name arity body = do
- func_args <- newIdents arity
+ func_args <- replicateM arity newIdent
FuncStat name func_args <$> (body $ toJExpr <$> func_args)
-- | Construct a top-level function subject to JS hoisting. Special case where
=====================================
compiler/GHC/Parser.y
=====================================
@@ -4332,6 +4332,9 @@ glNR ln = Anchor (realSrcSpan $ getLocA ln) UnchangedAnchor
glNRR :: LocatedN a -> EpaLocation
glNRR = srcSpan2e . getLocA
+n2l :: LocatedN a -> LocatedA a
+n2l (L la a) = L (l2l la) a
+
anc :: RealSrcSpan -> Anchor
anc r = Anchor r UnchangedAnchor
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -50,7 +50,7 @@ module GHC.Parser.Annotation (
-- ** Utilities for converting between different 'GenLocated' when
-- ** we do not care about the annotations.
- la2na, na2la, n2l, l2n, l2l, la2la,
+ l2l, la2la,
reLoc,
HasLoc(..), getHasLocList,
@@ -991,31 +991,15 @@ knowing that in most cases the original list is empty.
-- ---------------------------------------------------------------------
--- |Helper function (temporary) during transition of names
+-- |Helper function for converting annotation types.
-- Discards any annotations
-l2n :: LocatedAn a1 a2 -> LocatedN a2
-l2n (L la a) = L (noAnnSrcSpan (locA la)) a
+l2l :: (HasLoc a, HasAnnotation b) => a -> b
+l2l a = noAnnSrcSpan (getHasLoc a)
-n2l :: LocatedN a -> LocatedA a
-n2l (L la a) = L (na2la la) a
-
--- |Helper function (temporary) during transition of names
--- Discards any annotations
-la2na :: SrcSpanAnn' a -> SrcSpanAnnN
-la2na l = noAnnSrcSpan (locA l)
-
--- |Helper function (temporary) during transition of names
--- Discards any annotations
-la2la :: (NoAnn ann2) => LocatedAn ann1 a2 -> LocatedAn ann2 a2
-la2la (L la a) = L (noAnnSrcSpan (locA la)) a
-
-l2l :: SrcSpanAnn' a -> SrcAnn ann
-l2l l = SrcSpanAnn EpAnnNotUsed (locA l)
-
--- |Helper function (temporary) during transition of names
+-- |Helper function for converting annotation types.
-- Discards any annotations
-na2la :: (NoAnn ann) => SrcSpanAnn' a -> SrcAnn ann
-na2la l = noAnnSrcSpan (locA l)
+la2la :: (HasLoc l, HasAnnotation l2) => GenLocated l a -> GenLocated l2 a
+la2la (L la a) = L (noAnnSrcSpan (getHasLoc la)) a
locA :: (HasLoc a) => a -> SrcSpan
locA = getHasLoc
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1837,7 +1837,7 @@ instance DisambECP (HsExpr GhcPs) where
mkHsParPV l lpar e rpar = do
cs <- getCommentsFor l
return $ L (noAnnSrcSpan l) (HsPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar e rpar)
- mkHsVarPV v@(L l _) = return $ L (na2la l) (HsVar noExtField v)
+ mkHsVarPV v@(L l _) = return $ L (l2l l) (HsVar noExtField v)
mkHsLitPV (L l a) = do
cs <- getCommentsFor l
return $ L l (HsLit (comment (realSrcSpan l) cs) a)
@@ -1912,7 +1912,7 @@ instance DisambECP (PatBuilder GhcPs) where
mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat
mkHsDoPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)
- mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v)
+ mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v)
mkHsLitPV lit@(L l a) = do
checkUnboxedLitPat lit
return $ L l (PatBuilderPat (LitPat noExtField a))
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -244,7 +244,7 @@ finishHsVar (L l name)
= do { this_mod <- getModule
; when (nameIsLocalOrFrom this_mod name) $
checkThLocalName name
- ; return (HsVar noExtField (L (la2na l) name), unitFV name) }
+ ; return (HsVar noExtField (L (l2l l) name), unitFV name) }
rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
rnUnboundVar v = do
@@ -280,7 +280,7 @@ rnExpr (HsVar _ (L l v))
-> rnExpr (ExplicitList noAnn [])
| otherwise
- -> finishHsVar (L (na2la l) nm)
+ -> finishHsVar (L (l2l l) nm)
}}}
rnExpr (HsIPVar x v)
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -2539,7 +2539,7 @@ extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do {
return ((PatSynName bnd_name, con_info) : names)
| L bind_loc (PatSynBind _ (PSB { psb_id = L _ n, psb_args = as })) <- bind
= do
- bnd_name <- newTopSrcBinder (L (la2na bind_loc) n)
+ bnd_name <- newTopSrcBinder (L (l2l bind_loc) n)
let con_info = mkConInfo (conDetailsArity length as) []
return ((PatSynName bnd_name, con_info) : names)
| otherwise
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -869,10 +869,10 @@ getLocalNonValBinders fixity_env
new_tc dup_fields_ok has_sel tc_decl -- NOT for type/data instances
= do { let TyDeclBinders (main_bndr, tc_flav) at_bndrs sig_bndrs
(LConsWithFields cons_with_flds flds) = hsLTyClDeclBinders tc_decl
- ; tycon_name <- newTopSrcBinder $ l2n main_bndr
- ; at_names <- mapM (newTopSrcBinder . l2n . fst) at_bndrs
- ; sig_names <- mapM (newTopSrcBinder . l2n) sig_bndrs
- ; con_names_with_flds <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (l2n con)) cons_with_flds
+ ; tycon_name <- newTopSrcBinder $ la2la main_bndr
+ ; at_names <- mapM (newTopSrcBinder . la2la . fst) at_bndrs
+ ; sig_names <- mapM (newTopSrcBinder . la2la) sig_bndrs
+ ; con_names_with_flds <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (la2la con)) cons_with_flds
; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst con_names_with_flds) flds
; mapM_ (add_dup_fld_errs flds') con_names_with_flds
; let tc_gre = mkLocalTyConGRE (fmap (const tycon_name) tc_flav) tycon_name
@@ -947,7 +947,7 @@ getLocalNonValBinders fixity_env
new_di dup_fields_ok has_sel mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl })
= do { main_name <- unLoc <$> lookupFamInstName mb_cls (feqn_tycon ti_decl)
; let LConsWithFields cons_with_flds flds = hsDataFamInstBinders dfid
- ; sub_names <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (l2n con)) cons_with_flds
+ ; sub_names <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (la2la con)) cons_with_flds
; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst sub_names) flds
; mapM_ (add_dup_fld_errs flds') sub_names
; let fld_env = mk_fld_env sub_names flds'
@@ -2133,14 +2133,14 @@ printMinimalImports hsc_src imports_w_usage
to_ie_post_rn_var :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn
to_ie_post_rn_var (L l n)
- | isDataOcc $ occName n = L l (IEPattern (la2e l) (L (la2na l) n))
- | otherwise = L l (IEName noExtField (L (la2na l) n))
+ | isDataOcc $ occName n = L l (IEPattern (la2e l) (L (l2l l) n))
+ | otherwise = L l (IEName noExtField (L (l2l l) n))
to_ie_post_rn :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn
to_ie_post_rn (L l n)
- | isTcOcc occ && isSymOcc occ = L l (IEType (la2e l) (L (la2na l) n))
- | otherwise = L l (IEName noExtField (L (la2na l) n))
+ | isTcOcc occ && isSymOcc occ = L l (IEType (la2e l) (L (l2l l) n))
+ | otherwise = L l (IEName noExtField (L (l2l l) n))
where occ = occName n
{-
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -558,7 +558,7 @@ rnPatAndThen _ (NPat x (L l lit) mb_neg _eq)
; return (NPat x (L l lit') mb_neg' eq') }
rnPatAndThen mk (NPlusKPat _ rdr (L l lit) _ _ _ )
- = do { new_name <- newPatName mk (l2n rdr)
+ = do { new_name <- newPatName mk (la2la rdr)
; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]
-- We skip negateName as
-- negative zero doesn't make
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -391,12 +391,12 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name
mkQuasiQuoteExpr flavour quoter (L q_span' quote)
= L q_span $ HsApp noComments (L q_span
$ HsApp noComments (L q_span
- (HsVar noExtField (L (la2na q_span) quote_selector)))
+ (HsVar noExtField (L (l2l q_span) quote_selector)))
quoterExpr)
quoteExpr
where
q_span = noAnnSrcSpan (locA q_span')
- quoterExpr = L q_span $! HsVar noExtField $! (L (la2na q_span) quoter)
+ quoterExpr = L q_span $! HsVar noExtField $! (L (l2l q_span) quoter)
quoteExpr = L q_span $! HsLit noComments $! HsString NoSourceText quote
quote_selector = case flavour of
UntypedExpSplice -> quoteExpName
=====================================
compiler/GHC/Runtime/Eval.hs
=====================================
@@ -1241,7 +1241,7 @@ dynCompileExpr expr = do
parsed_expr <- parseExpr expr
-- > Data.Dynamic.toDyn expr
let loc = getLoc parsed_expr
- to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L (la2na loc) $ getRdrName toDynName)
+ to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L (l2l loc) $ getRdrName toDynName)
parsed_expr
hval <- compileParsedExpr to_dyn_expr
return (unsafeCoerce hval :: Dynamic)
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -2292,7 +2292,7 @@ mkFunBindSE arity loc fun pats_and_exprs
mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBind fun@(L loc _fun_rdr) matches
- = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches)
+ = L (l2l loc) (mkFunBind (Generated SkipPmc) fun matches)
-- | Make a function binding. If no equations are given, produce a function
-- with the given arity that uses an empty case expression for the last
@@ -2320,7 +2320,7 @@ mkRdrFunBindEC :: Arity
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
- = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches')
+ = L (l2l loc) (mkFunBind (Generated SkipPmc) fun matches')
where
-- Catch-all eqn looks like
-- fmap _ z = case z of {}
@@ -2344,7 +2344,7 @@ mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
mkRdrFunBindSE :: Arity -> LocatedN RdrName ->
[LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBindSE arity fun@(L loc fun_rdr) matches
- = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches')
+ = L (l2l loc) (mkFunBind (Generated SkipPmc) fun matches')
where
-- Catch-all eqn looks like
-- compare _ _ = error "Void compare"
=====================================
compiler/GHC/Tc/Gen/Export.hs
=====================================
@@ -710,7 +710,7 @@ lookupChildrenExport spec_parent rdr_items = mapAndReportM doOne rdr_items
do { ub <- reportUnboundName unboundName
; let l = getLoc n
gre = mkLocalGRE UnboundGRE NoParent ub
- ; return (L l (IEName noExtField (L (la2na l) ub)), gre)}
+ ; return (L l (IEName noExtField (L (l2l l) ub)), gre)}
FoundChild child@(GRE { gre_name = child_nm, gre_par = par }) ->
do { checkPatSynParent spec_parent par child_nm
; return (replaceLWrappedName n child_nm, child)
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -1542,7 +1542,7 @@ splitHsAppTys hs_ty
go (L _ (HsAppKindTy _ ty at k)) as = go ty (HsTypeArg at k : as)
go (L sp (HsParTy _ f)) as = go f (HsArgPar (locA sp) : as)
go (L _ (HsOpTy _ prom l op@(L sp _) r)) as
- = ( L (na2la sp) (HsTyVar noAnn prom op)
+ = ( L (l2l sp) (HsTyVar noAnn prom op)
, HsValArg l : HsValArg r : as )
go f as = (f, as)
=====================================
compiler/GHC/Tc/TyCl/Class.hs
=====================================
@@ -195,7 +195,7 @@ tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
tcdMeths = default_binds}))
= recoverM (return emptyLHsBinds) $
setSrcSpan (getLocA class_name) $
- do { clas <- tcLookupLocatedClass (n2l class_name)
+ do { clas <- tcLookupLocatedClass (la2la class_name)
-- We make a separate binding for each default method.
-- At one time I used a single AbsBinds for all of them, thus
@@ -281,7 +281,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars)
- lm_bind = dm_bind { fun_id = L (la2na bind_loc) local_dm_name }
+ lm_bind = dm_bind { fun_id = L (l2l bind_loc) local_dm_name }
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -610,7 +610,7 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
-- itself, so we make do with the location of family name
; (co_ax_branch, co_ax_validity_info)
<- tcTyFamInstEqn fam_tc mb_clsinfo
- (L (na2la $ getLoc fam_lname) eqn)
+ (L (l2l $ getLoc fam_lname) eqn)
-- (2) check for validity
; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -943,7 +943,7 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
mk_mg body = mkMatchGroup (Generated SkipPmc) (noLocA [builder_match])
where
- builder_args = [L (na2la loc) (VarPat noExtField (L loc n))
+ builder_args = [L (l2l loc) (VarPat noExtField (L loc n))
| L loc n <- args]
builder_match = mkMatch (mkPrefixFunRhs ps_lname)
builder_args body
=====================================
libraries/base/src/Data/Bifunctor.hs
=====================================
@@ -39,9 +39,23 @@ import GHC.Generics ( K1(..) )
-- Intuitively it is a bifunctor where both the first and second
-- arguments are covariant.
--
+-- The class definition of a 'Bifunctor' @p@ uses the
+-- [QuantifiedConstraints](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/quantified_constraints.html)
+-- language extension to quantify over the first type
+-- argument @a@ in its context. The context requires that @p a@
+-- must be a 'Functor' for all @a at . In other words a partially
+-- applied 'Bifunctor' must be a 'Functor'. This makes 'Functor' a
+-- superclass of 'Bifunctor' such that a function with a
+-- 'Bifunctor' constraint may use 'fmap' in its implementation.
+-- 'Functor' has been a quantified superclass of
+-- 'Bifunctor' since base-4.18.0.0.
+--
-- You can define a 'Bifunctor' by either defining 'bimap' or by
--- defining both 'first' and 'second'. A partially applied 'Bifunctor'
--- must be a 'Functor' and the 'second' method must agree with 'fmap'.
+-- defining both 'first' and 'second'. The 'second' method must
+-- agree with 'fmap':
+--
+-- @'second' ≡ 'fmap'@
+--
-- From this it follows that:
--
-- @'second' 'id' ≡ 'id'@
@@ -69,8 +83,6 @@ import GHC.Generics ( K1(..) )
-- 'second' (f '.' g) ≡ 'second' f '.' 'second' g
-- @
--
--- Since 4.18.0.0 'Functor' is a superclass of 'Bifunctor.
---
-- @since 4.8.0.0
class (forall a. Functor (p a)) => Bifunctor p where
{-# MINIMAL bimap | first, second #-}
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit b75ff8a88bbdd0d60032a4e304d37ec65526c06b
+Subproject commit 2cbf7f0a55898e0c2827ae9ad13727b34877e793
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7f1a5f996c77568d8920ec0ad77c22b83fb89ad8...1163a38a2fabddf037afd705218b5c74e7c34e3c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7f1a5f996c77568d8920ec0ad77c22b83fb89ad8...1163a38a2fabddf037afd705218b5c74e7c34e3c
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231106/20aa825f/attachment-0001.html>
More information about the ghc-commits
mailing list